Attribute VB_Name = "CommonFunction"
' обработка ошибок на совести Билагейтса, мне ее писать лениво
Option Compare Binary
Option Explicit

Const mnErrDeviceUnavailable = 68 ' устройство недоступно
Const mnErrDiskNotReady = 71 ' диск не готов
Const mnErrDeviceIO = 57 ' ошибка ввода/вывода
Const mnErrDiskFull = 61 ' диск полон
Const mnErrBadFileName = 64 ' неверное имя файла
Const mnErrBadFileNameOrNumber = 52 ' неверное имя или дескриптор файла
Const mnErrPathDoesNotExist = 76 ' путь несуществует
Const mnErrBadFileMode = 54 ' файл открыт в другом режимя
Const mnErrFileAlreadyOpen = 55 ' файл уже открыт
Const mnErrInputPastEndOfFile = 62 ' странный конец файла

Public Const SC_MINIMIZE = &HF020&

Public Const SW_HIDE = 0
Public Const SW_SHOWNORMAL = 1
Public Const SW_NORMAL = 1
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_MAXIMIZE = 3
Public Const SW_SHOWNOACTIVATE = 4
Public Const SW_SHOW = 5
Public Const SW_MINIMIZE = 6
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_RESTORE = 9
Public Const SW_SHOWDEFAULT = 10
Public Const SW_MAX = 10



Public Const NIM_ADD = 0
Public Const NIM_MODIFY = 1
Public Const NIM_DELETE = 2
Public Const NIF_MESSAGE = 1
Public Const NIF_ICON = 2
Public Const NIF_TIP = 4

Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206



Public Const WM_SYSCOMMAND = &H112
Public Const MF_STRING = &H0
Public Const SC_NEWMENU = 1
Public Const GWL_WNDPROC = -4

Public Const INI_COMMENT_DELIM = "\\"

Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

Type IniRecord   ' тип используемый в функциях чтения - записи ini-файла.
    Name As String      ' название параметра
    Value As String     ' значение параметра
    Section As String   ' секция параметра
    Comment As String   ' секция коментариев
    End Type


Dim IniFile() As IniRecord ' массив ini-файла
Dim IniSection() As String ' список секций в ini-файле



'Declare Sub MessageBeep Lib "user32" (ByVal intN As Integer)
Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
'Declare Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" (ByVal lpszSrc As String, ByVal lpszDst As String, ByVal cchDstLength As Long) As Long
Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Declare Function GetCommandLine Lib "kernel32" Alias "GetCommandLineA" () As String
Declare Function Shell_NotifyIconA Lib "SHELL32" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Integer
Declare Function IsCharAlpha Lib "user32" Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long
Declare Function IsCharAlphaNumeric Lib "user32" Alias "IsCharAlphaNumericA" (ByVal cChar As Byte) As Long
Declare Function IsCharLower Lib "user32" Alias "IsCharLowerA" (ByVal cChar As Byte) As Long
Declare Function IsCharUpper Lib "user32" Alias "IsCharUpperA" (ByVal cChar As Byte) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function ShowWindowAsync Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

'засунуть иконку в tray
Public Function SetTrayIcon(Mode As Long, hwnd As Long, Icon As Long, tip As String) As Long
    Dim nidTemp As NOTIFYICONDATA
    nidTemp.cbSize = Len(nidTemp)
    nidTemp.hwnd = hwnd
    nidTemp.uID = 0&
    nidTemp.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    nidTemp.uCallbackMessage = WM_LBUTTONDOWN
    nidTemp.hIcon = Icon
    nidTemp.szTip = tip & Chr$(0)
    SetTrayIcon = Shell_NotifyIconA(Mode, nidTemp)
End Function


Public Function ChangeNameToValue(SourceStr As String, Name As String, ValueName As String) As Boolean
' заменяет название на значение в строке SourceStr.
' если значение заменено - возвращает True иначе False
Dim Buffer As String
Dim PosStr As Variant
Dim LengthName As Long

    ChangeNameToValue = False
    Buffer = SourceStr
    PosStr = InStr(SourceStr, Name) ' сравнивать побайтно
    If IsNull(PosStr) Then
        Exit Function
        End If
    
    If PosStr = 0 Then
        Exit Function
        End If
    LengthName = Len(Name) ' получить длину строки  имени
    Buffer = Left(SourceStr, PosStr - 1) + ValueName + Mid(SourceStr, PosStr + Len(Name), Len(SourceStr))
    SourceStr = Buffer
    ChangeNameToValue = True
    End Function

   
Public Function IsActiveForm(Name As String) As Boolean
' определяет является ли форма открытой
Dim MyForm As Form
    
    IsActiveForm = False
    ' Перебирает компоненты семейства Forms.
    For Each MyForm In Forms
        ' Выводит имя формы.
         If MyForm.Name = Name Then
            IsActiveForm = True
            Exit Function
            End If
        Next MyForm
    End Function

Public Function LengthMonth(NumberMonth As Integer, NumberYear As String) As Integer
'возвращает количество дней в месяце
Dim Buffer As Variant
    If (NumberMonth < 0) Or (CDbl(NumberYear) < 0) Then
        LengthMonth = -1
        Exit Function
        End If
    Select Case NumberMonth
        Case 1, 3, 5, 7, 8, 10, 12
            LengthMonth = 31
        Case 4, 6, 9, 11
            LengthMonth = 30
        Case 2
            Buffer = "01.02." & NumberYear 'создать дату
            Buffer = DateAdd("D", 28, Buffer)
            If Month(Buffer) = 3 Then
                LengthMonth = 28
                Else
                LengthMonth = 29
                End If
        End Select
        
    End Function
    

Public Function NumberWeek(DateDay As Variant) As Integer
'определяет номер недели в месяце к которой принадлежит дата
 Dim CurrentYear As Variant
 Dim CurrentMonth As Variant
 Dim CurrentWeek As Variant
 Dim Buffer As Variant
 Dim FirstMonthDay As Variant
    If Not IsDate(DateDay) Then
        NumberWeek = -1
        Exit Function
        End If
        
    CurrentYear = Year(DateDay) 'определить текущий год
    CurrentMonth = Month(DateDay) 'определить месяц по дате
    Buffer = "01.01." & CurrentYear
    'получить номер текущей недели в году
    CurrentWeek = DateDiff("ww", Buffer, DateDay, vbMonday, vbFirstJan1)
    FirstMonthDay = "01." & CurrentMonth & "." & CurrentYear
    ' получить номер недели на которую приходиться первое число месяца
    Buffer = DateDiff("ww", Buffer, FirstMonthDay, vbMonday, vbFirstJan1)
    NumberWeek = CurrentWeek - Buffer + 1
    End Function

'правильная функция средствами УИНДОВС
Function AnsiToOem(strLine As String) As String 'конвертирует из виндовой кодировки в досовую
'несколько коряво но лень
   Dim strBuffer As String
   Dim res As Variant
   
   strBuffer = strLine ' выделить пространство в буфере для конвертации
   res = CharToOem(strLine, strBuffer) ' преобразовать ANSI кодировку в OEM
   AnsiToOem = strBuffer
   End Function
Function OemToAnsi(strLine As String) As String 'конвертирует из досовой кодировки в виндовую
'несколько коряво но лень
   Dim strBuffer As String
   Dim res As Variant
   
   strBuffer = strLine ' выделить пространство в буфере для конвертации
   res = OemToChar(strLine, strBuffer) ' преобразовать ANSI кодировку в OEM
   OemToAnsi = strBuffer
   End Function


Public Function AddStrToFile(strFileName As String, strLine As String, ErrCode As Integer) As Boolean
Dim iFile  As Integer

On Error GoTo Err_IOResult

    AddStrToFile = False

    If strFileName = "" Then Exit Function
        
    iFile = FreeFile()
    AddStrToFile = True
    Open strFileName For Append Shared As #iFile
    Print #iFile, strLine
    Close #iFile
    ErrCode = 0
    AddStrToFile = True
    Exit Function
    
Err_IOResult: 'обработка ошибки вывода строки в файл
    ErrCode = Err.Number
    Err.Clear
End Function

' получает каталог запуска программы со слешем в конце и полное имя с точкой точки
Public Function GetBaseExeName(strBaseName As String, strStartDir As String) As Boolean
Dim strTemp As String
Dim PosChr As Integer
Dim strLine As String
Dim strBuffer As String
    On Error Resume Next
    strBaseName = App.Path & "\" & App.EXEName & "."
    strStartDir = App.Path + "\"
    GetBaseExeName = True
    End Function


Function FileErrors() As Integer ' обработчик ошибок для работы с файлами
    Dim intMsgType As Integer
    Dim strMsg As String
    Dim intResponse As Integer
    ' Return Value      Meaning
    ' 0                 Resume
    ' 1                 Resume Next
    ' 2                 Unrecoverable error
    ' 3                 Unrecognized error
    intMsgType = vbExclamation
    Select Case Err.Number
        Case mnErrDeviceUnavailable             ' Error 68
            strMsg = "That device appears unavailable."
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrDiskNotReady                  ' Error 71
            strMsg = "Insert a disk in the drive and close the door."
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrDeviceIO                      ' Error 57
            strMsg = "Internal disk error."
            intMsgType = vbExclamation + vbOKOnly
        Case mnErrDiskFull                      ' Error 61
            strMsg = "Disk is full. Continue?"
            intMsgType = vbExclamation + vbAbortRetryIgnore
        Case mnErrBadFileName, mnErrBadFileNameOrNumber ' Error 64 & 52
            strMsg = "That filename is illegal."
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrPathDoesNotExist                ' Error 76
            strMsg = "That path doesn't exist."
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrBadFileMode                     ' Error 54
            strMsg = "Can't open your file for that type of access."
        Case mnErrFileAlreadyOpen             ' Error 55
            strMsg = "This file is already open."
            intMsgType = vbExclamation + vbOKOnly
        Case mnErrInputPastEndOfFile              ' Error 62
            strMsg = "This file has a nonstandard end-of-file marker, "
            strMsg = strMsg & "or an attempt was made to read beyond "
            strMsg = strMsg & "the end-of-file marker."
            intMsgType = vbExclamation + vbAbortRetryIgnore
        Case Else
            FileErrors = 3
            Exit Function
    End Select
    intResponse = MsgBox(strMsg, intMsgType, "Disk Error")
    Select Case intResponse
        Case 1, 4       ' OK, Retry buttons.
            FileErrors = 0
        Case 2, 5       ' Cancel, Ignore buttons.
            FileErrors = 1
        Case 3          ' Abort button.
            FileErrors = 2
        Case Else
            FileErrors = 3
    End Select
End Function


' возвращает значения до первого разделителя и bResult = True, если разделителя нет - возвращает строку
' bResult=False  и отрезает входную строку

Public Function GetFirstParam(strLine As String, strDelimiter As String, bResult As Boolean) As String
Dim iPosChr As Integer
    bResult = False
    iPosChr = InStr(strLine, strDelimiter)
    If iPosChr > 0 Then
        GetFirstParam = Left(strLine, iPosChr - 1)
        strLine = Right(strLine, Len(strLine) - iPosChr + 1 - Len(strDelimiter))
        bResult = True
        Else
        GetFirstParam = strLine
        End If 'If PosChr > 0
    
    End Function




Public Function ReadIniFile(strFileIniName As String) As Boolean
Dim strTemp As String
Dim strBuff As String
Dim IniVar As IniRecord
Dim strSection As String
Dim strComment As String
Dim iCount As Integer
Dim bResult As Boolean
Dim iFile As Integer
'On Error GoTo Err_ReadIniFile

    ReadIniFile = False
    strSection = ""
    iFile = FreeFile()
    Open strFileIniName For Input Shared As #iFile
    ReDim IniFile(0) ' сбросить все параметры
        
    Do While Not EOF(iFile)
        Input #iFile, strTemp ' вычитать строку из INI файла
        strBuff = strTemp
        strTemp = UCase(LTrim(strTemp)) 'привести к верхнему регистру и убить пробелы спереду
        
        'сложный анализ
        If Len(strTemp) = 0 Then GoTo NextStep ' убить пустые строки
        If Left(strTemp, 1) = ";" Then GoTo NextStep ' если в начале строки стоит ;
        If InStr(strTemp, "REM ") > 0 Then GoTo NextStep 'если в начале строки стоит REM
        
        If (Left(strTemp, 1) = "[") And (InStr(strTemp, "]") > 0) Then ' если в начале строки стоит [
            strSection = Trim(Mid(strTemp, 2, InStr(strTemp, "]") - 2))
        End If 'If (Left(strTemp, 1) = "[") And (InStr(strTemp, "]") > 0)
        
        If Left(strTemp, 1) = "=" Then GoTo NextStep ' если в начале строки стоит =
        If InStr(strTemp, "=") = 0 Then GoTo NextStep 'если  нет = (по ошибке например)
        strComment = GetIndexParam(strBuff, 2, INI_COMMENT_DELIM) ' вычленить комментарии
        strTemp = GetIndexParam(strTemp, 1, INI_COMMENT_DELIM)
               
        IniVar.Name = Trim(Left(strTemp, InStr(strTemp, "=") - 1)) 'имя переменной берется преобразованное к верхнему регистру
        strBuff = Left(strBuff, Len(strTemp))
        IniVar.Value = Trim(Right(strBuff, Len(strTemp) - InStr(strTemp, "="))) ' а значение -  неееет...
        ReDim Preserve IniFile(UBound(IniFile) + 1)
        IniFile(UBound(IniFile)).Name = IniVar.Name
        IniFile(UBound(IniFile)).Value = IniVar.Value
        IniFile(UBound(IniFile)).Section = strSection
        IniFile(UBound(IniFile)).Comment = strComment
        
NextStep: ' некрасиво , но штатных методов похоже нет
        Loop
    
    Close #iFile ' закрыть файл настроек
    ReadIniFile = True
    
    Exit Function ' завершить процедурочку
    ' обработка ошибок

Err_ReadIniFile: 'обработка ошибки чтения строки из файла
    'strBuff = "Ошибка доступа к файлу инициализации " & Chr(13) & Chr(10) & strFileIniName & Chr(32) & Err.Number
    'MsgBox strBuff, vbOKOnly, "Ошибка !"
    Err.Clear
    ReDim IniFile(0) ' сбросить все
    

End Function


Public Function GetIniParam(Section As String, Name As String, Value As String) As Boolean
Dim iCount As Integer
On Error GoTo Err_GetIniParam
    GetIniParam = False ' ПРИЧИНУ БУДЕТ НЕ УЗНАТЬ, НО ОШИБКУ ЧТЕНИЯ ВЕРНЕТ
    If UBound(IniFile) = 0 Then Exit Function
    For iCount = 1 To UBound(IniFile)
        If (IniFile(iCount).Section = UCase(Section)) And _
            (IniFile(iCount).Name = UCase(Name)) Then
            Value = IniFile(iCount).Value
            GetIniParam = True
            Exit Function
            End If
        Next iCount
    Exit Function
Err_GetIniParam:
    Err.Clear
    
End Function
Public Function SetIniParam(strSection As String, strName As String, strValue As String, strComment As String) As Boolean
Dim iCount As Integer
On Error GoTo Err_GetIniParam
    SetIniParam = False ' ПРИЧИНУ БУДЕТ НЕ УЗНАТЬ, НО ОШИБКУ ЧТЕНИЯ ВЕРНЕТ
    If UBound(IniFile) = 0 Then Exit Function
    For iCount = 1 To UBound(IniFile)
        If (IniFile(iCount).Section = UCase(strSection)) And _
            (IniFile(iCount).Name = UCase(strName)) Then
            IniFile(iCount).Value = strValue
            SetIniParam = True
            Exit Function
            End If
        Next iCount
     ' если параметра нет - добавить
    ReDim Preserve IniFile(UBound(IniFile) + 1)
    IniFile(UBound(IniFile)).Name = strName
    IniFile(UBound(IniFile)).Value = strValue
    IniFile(UBound(IniFile)).Section = strSection
    IniFile(UBound(IniFile)).Comment = AnsiToOem(strComment)
    SetIniParam = True
      
    Exit Function
Err_GetIniParam:
    Err.Clear
    
End Function

' создает ini-файл из прочитаных параметров
Public Function SaveIniFile(strFileIniName As String) As Boolean
Dim iSection As Integer
Dim iParam As Integer
Dim iFile As Integer
Dim strSectionCurr As String
Dim arrUsedSection()
Dim strBuff As String
Dim bRes As Boolean

On Error GoTo Err_SaveIniFile
    
    SaveIniFile = False
    iFile = FreeFile()
    ReDim arrUsedSection(0)
    Open strFileIniName For Output Shared As #iFile
    'метод тотального перебора
    strSectionCurr = ""
    For iSection = 1 To UBound(IniFile)
        If strSectionCurr <> IniFile(iSection).Section Then ' если секция изменилась
            bRes = False
            If UBound(arrUsedSection) > 0 Then
                For iParam = 1 To UBound(arrUsedSection) ' проверить была ли такая секция перед
                    strBuff = arrUsedSection(iParam)
                    If strBuff = IniFile(iSection).Section Then
                        bRes = True
                        iParam = UBound(arrUsedSection)
                    End If 'If strBuff = IniFile(iSection).Section Then
                Next iParam 'For iParam = 1 To UBound(arrUsedSection)
            End If 'If UBound(arrUsedSection) > 0 Then
            If bRes Then GoTo NextStep ' если такая секция уже обрабатывалась
            Print #iFile, "" ' Секция принята к обработке
            strSectionCurr = IniFile(iSection).Section
            ReDim Preserve arrUsedSection(UBound(arrUsedSection) + 1)
            arrUsedSection(UBound(arrUsedSection)) = strSectionCurr ' сохранить секцию, как уже обработаную
            Print #iFile, "[" & strSectionCurr & "]"
            For iParam = 1 To UBound(IniFile)
                If strSectionCurr = IniFile(iParam).Section Then
                strBuff = IniFile(iParam).Name & "=" & IniFile(iParam).Value
                If Len(IniFile(iParam).Comment) > 0 Then strBuff = strBuff & " " & INI_COMMENT_DELIM & IniFile(iParam).Comment
                Print #iFile, strBuff
                End If 'If strSectionCurr = IniFile(iParam).Section Then
            Next iParam 'For iParam = 1 To UBound(IniFile)
        End If 'strSectionCurr <> IniFile(iSection).Section Then ' если секция изменилась
NextStep:
    Next iSection 'For iSection = 1 To UBound(IniFile)
        
    Close #iFile
    ReDim arrUsedSection(0)
    SaveIniFile = True
    Exit Function
Err_SaveIniFile:
    Err.Clear
    ReDim arrUsedSection(0)
End Function

' возвращает параметр номер iIndex из строки strParam с разделителями iDelimiter
Public Function GetIndexParam(strParam As String, iIndex As Integer, strDelimiter As String) As String
Dim strBuff As String ' переменная, чтобы не менять strParam (правда можно передавать по значению, но лениво)
Dim iCount As Integer
Dim iPos As Integer ' последнее вхождение искомого делимитера
Dim iPosOld As Integer ' предпоследнее вхождение искомого делимитера
Dim iSize As Integer
Dim iDelim As Integer

    GetIndexParam = ""
    If iIndex < 1 Then Exit Function
    iSize = Len(strParam)
    iDelim = Len(strDelimiter)
    If (iSize <= iDelim) Or (iSize = 0) Or (iDelim = 0) Or (iIndex = 0) Then Exit Function
    strBuff = strParam
    'добавляет последний разделитель, если оный отсутствует
 
    If Right(strBuff, Len(strDelimiter)) <> strDelimiter Then strBuff = strBuff & strDelimiter
    
    iSize = Len(strParam)
    iPos = 1
    iPosOld = 1
   
    For iCount = 1 To iIndex
        If (iPosOld > iSize) Then Exit Function
        iPos = InStr(iPos, strBuff, strDelimiter)
        If IsNull(iPos) Or (iPos = 0) Then Exit Function ' если больше нет вхождений
        If (iCount = iIndex) Then Exit For
        iPosOld = iPos + iDelim ' запомнить старую позицию
        iPos = iPos + 1
        Next iCount
   'если досчитали до этого места - начать обработку
   GetIndexParam = Mid(strBuff, iPosOld, iPos - iPosOld)
End Function


' функция возвращает количество вхождений strToken в strLine
Public Function CountStr(strLine As String, strToken As String) As Integer
Dim iPos As Integer
Dim iCount As Integer
    iCount = 0
    iPos = 0
    Do
       iPos = InStr(iPos + 1, strLine, strToken)
       If iPos > 0 Then
        iCount = iCount + 1
        Else
        Exit Do
        End If 'If iPos > 0
      Loop While True
    CountStr = iCount
End Function
' возвращает True, если все символы в строке - буквы
Public Function IsAlpha(strChar As String) As Boolean
Dim iIndex As Integer

    IsAlpha = False
    If Len(strChar) = 0 Then Exit Function
    For iIndex = 1 To Len(strChar)
        Select Case Asc(Mid(strChar, iIndex, 1))
            Case 0 To 64, 91 To 96, 123 To 191
                Exit Function
            End Select
        Next iIndex
    IsAlpha = True
End Function

' //возвращает значеие бита в указанном числе из указанной позиции.
'//Позиция - от нуля}

Public Function GetByte(lValue As Long, lPos As Byte) As Long
Dim iMask As Long
Dim iCount As Byte

    iMask = 1
    
    For iCount = 1 To lPos
        iMask = iMask * 2
    Next iCount
    If ((lValue And iMask) <> 0) Then
        GetByte = 1
    Else
        GetByte = 0
    End If

    
' вычислить маску для позиции
End Function ' Public Function GetByte(lValue As Long, lPos As Byte) As Long



