Attribute VB_Name = "Accsess"
'10110001010011010111100001010100101000101110101001100110011000101000110100010100011001000101011001101
''     ''      ''''       '''''''''  ''    ''  ''''''''  ''''''''    100101010011011011010111001101100
''     ''      ''''      '''      '' ''   ''   ''        ''     '''  0 Copyright © 2006              1
'''''''''     ''  ''    ''           ''  ''    ''''''''  ''     ''   1 icq: 334479038                0
'''''''''    ''    ''   ''           ''''''    ''''''''  ''''''''    0 e-mail: VisualBasic@xaker.ru  1
''     ''   ''''''''''  ''           ''   ''   ''        ''     ''   1 web: www.aia.net.ua           0
''     ''  ''        '' '''       '' ''    ''  ''        ''      ''  0 Ukranian. Kharkov.            1
''     '' ''          ''  '''''''''  ''     '' ''''''''' ''       '' 100101010011011011010111010011011
'10110001010011010111100001010100101000101110101001100110011000101000110100010100011001000101011100110

'Модуль для работы с базой данных Accsess через ActiveX Data Objects (ADO)
'
'1) Project>References "Microsoft ActiveX Data Object Library 2.7"
'2) Project>References "Microsoft ADO Ext. for DLL and Security"

Public DescriptionLastError As String

Public Type ColumnInfo
    sValue   As String
    sType    As ADOX.KeyTypeEnum
    sName    As String
End Type

Public Function GetListStolbec(DBPath As String, DBTable As String, _
                               ReturnArray() As ColumnInfo, Optional Password As String) As Long  '+
'Возвращает массив столбцов в таблице
'В случае успеха функция принимает значение 0, иначе номер ошибки

Dim cn As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rs As New ADODB.Recordset

On Error GoTo e
    cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & DBPath$ & ";" & _
        IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & Trim$(Password$) & ";", ""

    cn.Open
    If cn.state = 0 Then cn.Open
    Set cmd.ActiveConnection = cn
    cmd.CommandText = "[" & DBTable & "]"
    cmd.CommandType = adCmdTable
    Set rs = cmd.Execute
    MyFieldCount = rs.Fields.Count

    ReDim ReturnArray(MyFieldCount - 1)
    For myIndex = 0 To MyFieldCount - 1
        ReturnArray(myIndex).sName = rs.Fields(myIndex).name
        ReturnArray(myIndex).sType = rs.Fields(myIndex).Type
        ReturnArray(myIndex).sValue = rs.Fields(myIndex).Value
    Next
    GetListStolbec = 0
    Set rs = Nothing
    Set cmd = Nothing
    Set cn = Nothing
Exit Function
e:
    Select Case Err.Number
        Case 94, 3021
            Resume Next
    End Select
    ReDim ReturnArray(0)
    Debug.Print Err.Description
    GetListStolbec = Err.Number
    escriptionLastError = Err.Description
    On Error GoTo 0: On Error Resume Next
    Set rs = Nothing
    Set cmd = Nothing
    Set cn = Nothing
End Function

Public Function GetTableArray(DataBasePath As String, Password As String, _
                              ReturnArray() As String) As Long '+
'Возвращаем массив ReturnArray с именами таблиц
'В случае успеха функция принимает значение 0, иначе номер ошибки

Set dbObj = New ADODB.Connection
Dim rsSchema As ADODB.Recordset
Dim dbConnectionString As String

On Error GoTo e
dbConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & DataBasePath$ & ";" & _
 IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & Trim$(Password$) & ";", ""

    ReDim ReturnArray(0)
    dbObj.Open dbConnectionString
    
    If dbObj.state = adStateOpen Then
        Set rsSchema = dbObj.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "TABLE")
        If Not rsSchema Is Nothing Then
            Do While Not rsSchema.EOF
                If UCase(Left(rsSchema!Table_name, 4)) <> "MSYS" Then
                    If UCase(Left(rsSchema!Table_name, 11)) <> "SWITCHBOARD" Then
                        NewTableName = rsSchema!Table_name
                        ReturnArray(UBound(ReturnArray)) = NewTableName
                        ReDim Preserve ReturnArray(UBound(ReturnArray) + 1)
                    End If
                End If
                rsSchema.MoveNext
            Loop
        End If
    End If
    'ReDim Preserve ReturnArray(UBound(ReturnArray) - 1)
    GetTableArray = 0
    rsSchema.Close
    Set rsSchema = Nothing
    Set dbObj = Nothing
    Exit Function
e:
    GetTableArray = Err.Number
    Debug.Print Err.Description
    escriptionLastError = Err.Description
    On Error GoTo 0: On Error Resume Next
    Set rsSchema = Nothing
    Set dbObj = Nothing
End Function

Public Function CreateNewTable(DataBasePath As String, TableName As String, _
                               Optional Password As String) As Long '+
'Создаём таблицу в созданной базе данных
'В случае успеха, возвращает 0, иначе номер ошибки

On Error GoTo e
    Dim oCat As ADOX.Catalog
    Dim oTable As New Table
    Set oCat = New ADOX.Catalog
    
    oCat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & _
     ataBasePath$ & ";" & IIf(Trim$(Password) <> "", "Jet OLEDB:Database Password=" & _
     Trim$(Password$) & ";", ""

    oTable.name = TableName
    oCat.Tables.Append oTable
    
    Set oTable = Nothing
    CreateNewTable = 0
    Exit Function
e:
    Debug.Print Err.Description
    escriptionLastError = Err.Description
    CreateNewTable = Err.Number
    On Error GoTo 0: On Error Resume Next
    Set oTable = Nothing
    Set oCat = Nothing
End Function

Public Function DeleteTable(DataBasePath As String, TableName As String, _
                               Optional Password As String) As Long '+
'Создаём таблицу в созданной базе данных
'В случае успеха, возвращает 0, иначе номер ошибки

On Error GoTo e
    Dim oCat As ADOX.Catalog
    Dim oTable As New Table
    Set oCat = New ADOX.Catalog
    
    oCat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & _
     ataBasePath$ & ";" & IIf(Trim$(Password) <> "", "Jet OLEDB:Database Password=" & _
     Trim$(Password$) & ";", ""

    oTable.name = TableName
    oCat.Tables.Delete TableName
    
    Set oTable = Nothing
    eleteTable = 0
    Exit Function
e:
    Debug.Print Err.Description
    escriptionLastError = Err.Description
    eleteTable = Err.Number
    On Error GoTo 0: On Error Resume Next
    Set oTable = Nothing
    Set oCat = Nothing
End Function

Public Function CreateDB(DataBasePath As String, Optional Password As String) As Long '+
'Создаёт новую, пустую, базу данных. Есть возможность установки пароля.
'При успехе возвращает 0, иначе номер ошибки

On Error GoTo e

    Dim oCat As ADOX.Catalog
    Set oCat = New ADOX.Catalog
    
    oCat.Create "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & DataBasePath$ & ";" & _
     IIf(Trim$(Password$) <> "", "Jet OLEDB:Database Password ='" & Trim$(Password$) & _
     "'", ""
    
    Set oCat = Nothing
    CreateDB = 0
    
e:
    Debug.Print Err.Description
    escriptionLastError = Err.Description
    CreateDB = Err.Number
    On Error GoTo 0: On Error Resume Next
    Set oCat = Nothing
End Function

Public Function RenameTable(DataBasePath As String, oldName As String, _
                            newName As String, Optional Password As String) As Long '+
'Переименовует таблицу
'В случае успеха возвращает 0, иначе номер ошибки
On Error GoTo e
Dim objADOXDatabase As ADOX.Catalog
Set objADOXDatabase = New ADOX.Catalog
     
  objADOXDatabase.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & _
   ataBasePath$ & ";" & IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & _
   Trim$(Password$) & ";", ""

  objADOXDatabase.Tables(oldName).name = newName
  Set objADOXDatabase = Nothing
  RenameTable = 0
  Exit Function
e:
    Debug.Print Err.Description
    escriptionLastError = Err.Description
    RenameTable = Err.Number
    On Error GoTo 0: On Error Resume Next
    Set objADOXDatabase = Nothing
End Function

Public Function ChangePassword(DataBasePath As String, _
                              strNewPassword As String, _
                              Optional strOldPassword As String) As Long '+

'Устанавливает/Изменяет пароль на базе данных Accsess
'При успехе возвращает 0, иначе номер ошибки

On Error GoTo e
Dim conn As ADODB.Connection
Set conn = New ADODB.Connection
    
    If Trim$(strOldPassword$) = "" Then strOldPassword = "Null"
    
    conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & _
     ataBasePath$ & ";" & IIf(Trim(strOldPassword) <> "" And strOldPassword <> "Null", _
     "Jet OLEDB:Database Password=" & strOldPassword & ";", ""
     
    conn.mode = adModeShareExclusive
    conn.Open
    conn.Execute "ALTER DATABASE PASSWORD " & strNewPassword & " " & strOldPassword
    conn.Close
    
    Set conn = Nothing
    ChangePassword = 0
    Exit Function
e:
    Debug.Print Err.Description
    escriptionLastError = Err.Description
    ChangePassword = Err.Number
    On Error GoTo 0: On Error Resume Next
    Set conn = Nothing
End Function

Public Function AddToDB(DataBasePath As String, Table As String, DvuhmerniyMassiv() As String, Optional Password As String) As Long      '+
'Добавляет данные из двухмерного массива в таблицу базы данных

'DvuhmerniyMassiv(cтрока, столбец)
    
    Dim i As Integer, j As Integer
    Dim Statement As String, new_value As String
    Dim conn As ADODB.Connection
    Set conn = New ADODB.Connection

On Error GoTo e
    
    conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & _
   ataBasePath$ & ";" & IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & _
   Trim$(Password$) & ";", ""
   
   conn.Open
   
   For i = 0 To UBound(DvuhmerniyMassiv, 1)
        Statement = "INSERT INTO [" & Trim$(Table$) & "] VALUES ("
        For j = 0 To UBound(DvuhmerniyMassiv, 2)
            If j > 0 Then Statement = Statement & " , "
            new_value$ = Trim$(DvuhmerniyMassiv(i, j))
                Statement = Statement & "'" & Trim$(new_value$) & "'"
        Next j
        Statement = Statement & ""
        conn.Execute Statement, , adCmdText
   Next i
   AddToDB = 0
   Set conn = Nothing
   Exit Function
e:
    Debug.Print Err.Description
    escriptionLastError = Err.Description
    AddToDB = Err.Number
    On Error GoTo 0: On Error Resume Next
   conn.Close
   Set conn = Nothing
End Function


Public Sub WritetoListView(ListView As ListView, DBAccess As String, DBTable As String, _
                Optional Password As String) '+

'Отображает базу в ListView
On Error GoTo e
    ListView.View = lvwReport
    Dim sArrayColumn() As ColumnInfo
    Call GetListStolbec(DBAccess, DBTable, sArrayColumn, Password)

    For i = 0 To UBound(sArrayColumn) 'Создаём столюцы
        ListView.ColumnHeaders.Add , , sArrayColumn(i).sName
    Next i

    Dim sArrayTable() As String
    Call GetArrayFromTable(DBAccess, DBTable, sArrayTable, Password)
    
        For q = 0 To UBound(sArrayTable, 1)
            Set lvItm = ListView.ListItems.Add(, , sArrayTable(q, 0))
            For i = 1 To UBound(sArrayTable, 2)
                lvItm.SubItems(i) = sArrayTable(q, i)
            Next i
        Next q
e:
End Sub

Public Function Export2XL(InitRow As Long, DBAccess As String, DBTable As String, _
                          Optional Password As String) As Long  '+
                          
' Экспортирует с базы в Exel
Dim cn As New ADODB.Connection           'Use for the connection string
Dim cmd As New ADODB.Command          'Use for the command for the DB
Dim rs As New ADODB.Recordset             'Recordset return from the DB
Dim myIndex As Integer                            'Used for Index
Dim MyRecordCount As Long                    'Store the number of record on the table
Dim MyFieldCount As Integer                    'Store the number of fields or column
Dim ApExcel As Object                             'To open Excel
Dim MyCol As String
Dim Response As Integer


Set ApExcel = CreateObject("Excel.application"  'Creates an object

ApExcel.Visible = True                                       'This enable you to see the process in Excel
ApExcel.Workbooks.Add                                   'Adds a new book.

'Set the connection string
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & DBAccess$ & ";" & _
 IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & Trim$(Password$) & ";", ""
'Open the connection
cn.Open

'Check that the connection is open
If cn.state = 0 Then cn.Open
Set cmd.ActiveConnection = cn
cmd.CommandText = "[" & DBTable & "]"
cmd.CommandType = adCmdTable
Set rs = cmd.Execute
'Count the number of fields or column
MyFieldCount = rs.Fields.Count

'Fill the first line with the name of the fields
For myIndex = 0 To MyFieldCount - 1
    ApExcel.Cells(InitRow, (myIndex + 1)).formula = rs.Fields(myIndex).name   'Write Title to a Cell
    ApExcel.Cells(InitRow, (myIndex + 1)).Font.Bold = True
    ApExcel.Cells(InitRow, (myIndex + 1)).interior.colorindex = 36
    ApExcel.Cells(InitRow, (myIndex + 1)).WrapText = True
Next

'Draw border on the title line
MyCol = Chr((64 + myIndex)) & InitRow
ApExcel.Range("A" & InitRow & ":" & MyCol).Borders.color = RGB(0, 0, 0)
MyRecordCount = 1 + InitRow

'Fill the excel book with the values from the database
Do While rs.EOF = False
For myIndex = 1 To MyFieldCount
    ApExcel.Cells(MyRecordCount, myIndex).formula = rs((myIndex - 1)).Value     'Write Value to a Cell
    ApExcel.Cells(MyRecordCount, myIndex).WrapText = False 'Format the Cell
Next
    MyRecordCount = MyRecordCount + 1
    rs.MoveNext
    If MyRecordCount > 50 Then
        Exit Do
    End If
Loop

'Close the connection with the DB
rs.Close

'Return the last position in the workbook
Export2XL = MyRecordCount
End Function

Public Function Export2HTML(DBAccess As String, DBTable As String, _
                            HtmlFile As String, Optional Password As String) As Long '+
                          
' Экспортирует с БД в HtmlFile

On Error GoTo e
Dim cn As New ADODB.Connection, cmd As New ADODB.Command, rs As New ADODB.Recordset
Dim myIndex As Integer, MyFieldCount As Integer, Response As Integer
Dim MyRecordCount As Long
Dim MyCol As String, HtmlCode As String
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & DBAccess$ & ";" & _
 IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & Trim$(Password$) & ";", ""
cn.Open
If cn.state = 0 Then cn.Open
Set cmd.ActiveConnection = cn
cmd.CommandText = "[" & DBTable & "]"
cmd.CommandType = adCmdTable
Set rs = cmd.Execute
MyFieldCount = rs.Fields.Count
rs.MoveFirst
'Формируем заголовок
HtmlCode$ = HtmlCode$ & "<html>" & vbCrLf
HtmlCode$ = HtmlCode$ & "<meta http-equiv=content-type content=" & Chr$(34) & "text/html; charset=windows-1251" & Chr$(34) & ">" & vbCrLf
HtmlCode$ = HtmlCode$ & "<table border=" & Chr$(34) & "1" & Chr$(34) & " style=" & Chr$(34) & "font-size:9pt;" & Chr$(34) & ">" & vbCrLf
HtmlCode$ = HtmlCode$ & "<tr bgcolor=" & Chr$(34) & "#cccccc" & Chr$(34) & ">" & vbCrLf
For myIndex = 0 To MyFieldCount - 1 'Строим заголовк столбцов
    HtmlCode$ = HtmlCode$ & "<td width=" & Chr$(34) & rs(myIndex).DefinedSize & Chr$(34) & ">" & vbCrLf
    HtmlCode$ = HtmlCode$ & "<p>" & rs(myIndex).name & "</p>" & vbCrLf
    HtmlCode$ = HtmlCode$ & "</td>" & vbCrLf
Next myIndex
HtmlCode$ = HtmlCode$ & "</tr>" & vbCrLf
rs.MoveFirst
Do While rs.EOF = False 'Далее строим саму таблицу
HtmlCode$ = HtmlCode$ & "<tr>" & vbCrLf
    For myIndex = 0 To MyFieldCount - 1
         HtmlCode$ = HtmlCode$ & "<td width=" & Chr$(34) & rs(myIndex).DefinedSize & Chr$(34) & ">" & vbCrLf
         HtmlCode$ = HtmlCode$ & "<p> &nbsp;" & rs(myIndex).Value & "</p>" & vbCrLf
         HtmlCode$ = HtmlCode$ & "</td>" & vbCrLf
    Next
    HtmlCode$ = HtmlCode$ & "</tr>" & vbCrLf
    rs.MoveNext
Loop
HtmlCode$ = HtmlCode$ & "</table>" & vbCrLf
HtmlCode$ = HtmlCode$ & "</html>" & vbCrLf
rs.Close
SaveToFile HtmlCode$, HtmlFile$ 'Сохраняем переменную в файл
Export2HTML = 0
Set rs = Nothing
Set cmd = Nothing
Set cn = Nothing
Exit Function
e:
Set rs = Nothing
Set cmd = Nothing
Set cn = Nothing
Export2HTML = Err.Number
DescriptionLastError = Err.Description
Debug.Print Err.Description
End Function

Public Function GetArrayDataByKeyColumn(DBAccess As String, DBTable As String, _
                KeyColumn As String, FindData As String, ReturnArray() As ColumnInfo, _
                Optional Password As String, Optional ReturnMaxRecords As Long) As Long  '+
                          
' Экспортирует с базы в Exel
Dim cn As New ADODB.Connection           'Use for the connection string
Dim cmd As New ADODB.Command          'Use for the command for the DB
Dim rs As New ADODB.Recordset             'Recordset return from the DB
Dim myIndex As Integer                            'Used for Index
Dim MyRecordCount As Long                    'Store the number of record on the table
Dim MyFieldCount As Integer                    'Store the number of fields or column

On Error GoTo e
'Set the connection string
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & DBAccess$ & ";" & _
 IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & Trim$(Password$) & ";", ""
'Open the connection
cn.Open

'Check that the connection is open
If cn.state = 0 Then cn.Open
Set cmd.ActiveConnection = cn
cmd.CommandText = "[" & DBTable & "]"
cmd.CommandType = adCmdTable
Set rs = cmd.Execute
'Count the number of fields or column
MyFieldCount = rs.Fields.Count
Do While rs.EOF = False
    For myIndex = 1 To MyFieldCount
        If rs((myIndex - 1)).name = KeyColumn And rs((myIndex - 1)).Value = FindData Then c = c + 1
    Next
    rs.MoveNext
Loop
If c < 1 Then c = 1
ReDim ReturnArray(c - 1, MyFieldCount - 1)
rs.MoveFirst
Do While rs.EOF = False
    For myIndex = 1 To MyFieldCount
        If rs((myIndex - 1)).name = KeyColumn And rs((myIndex - 1)).Value = FindData Then
            For i = 0 To MyFieldCount - 1
                ReturnArray(cc, i).sName = rs(i).name
                ReturnArray(cc, i).sType = rs(i).Type
                ReturnArray(cc, i).sValue = rs(i).Value
            Next i
            cc = cc + 1
        End If
    Next
    rs.MoveNext
    ReturnMaxRecords = ReturnMaxRecords + 1
Loop
'Close the connection with the DB
rs.Close
Set cn = Nothing
Set cmd = Nothing
Set rs = Nothing
GetArrayDataByKeyColumn = 0
Exit Function
e:
    escriptionLastError = Err.Description
    Debug.Print Err.Description
    GetArrayDataByKeyColumn = Err.Number
    On Error GoTo 0: On Error Resume Next
    rs.Close
    Set cn = Nothing
    Set cmd = Nothing
    Set rs = Nothing
End Function

Public Function GetArrayFromTable(DBAccess As String, DBTable As String, _
                ReturnArray() As String, Optional Password As String) As Long '+                   '+
                          
' Получает двухмерный массив с значениями таблицы из БД
Dim cn As New ADODB.Connection           'Use for the connection string
Dim cmd As New ADODB.Command          'Use for the command for the DB
Dim rs As New ADODB.Recordset             'Recordset return from the DB
Dim myIndex As Integer                            'Used for Index
Dim MyRecordCount As Long                    'Store the number of record on the table
Dim MyFieldCount As Integer                    'Store the number of fields or column
Dim sConnection As String
On Error GoTo e
'Set the connection string
sConnection = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & DBAccess$ & ";" & _
 IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & Trim$(Password$) & ";", ""
cn.ConnectionString = sConnection
'Open the connection
cn.Open
'Второй рекордсет для определения кол-во записей
Dim myKeyRst As ADODB.Recordset
Set myKeyRst = New ADODB.Recordset
sql$ = "Select * From [" & DBTable & "]"
myKeyRst.Open sql$, cn, adOpenKeyset
c = myKeyRst.RecordCount
'----
'Check that the connection is open
If cn.state = 0 Then cn.Open
Set cmd.ActiveConnection = cn
cmd.CommandText = "[" & DBTable & "]"
cmd.CommandType = adCmdTable
Set rs = cmd.Execute
'Count the number of fields or column
MyFieldCount = rs.Fields.Count
ReDim ReturnArray(c - IIf(c = 0, 0, 1), MyFieldCount - 1)
rs.MoveFirst
Do While rs.EOF = False
    For i = 0 To MyFieldCount - 1
        ReturnArray(cc, i) = rs(i).Value
    Next i
    cc = cc + 1
    rs.MoveNext
Loop
rs.Close
Set cn = Nothing
Set cmd = Nothing
Set rs = Nothing
GetArrayFromTable = 0
Exit Function
e:
    Select Case Err.Number
        Case 94: Resume Next
    End Select
    escriptionLastError = Err.Description
    Debug.Print Err.Description
    GetArrayFromTable = Err.Number
    On Error GoTo 0: On Error Resume Next
    Set cn = Nothing
    Set cmd = Nothing
    Set rs = Nothing
End Function

Public Function DelRecordFromTable(DBAccess As String, DBTable As String, _
                IndexRecord As Long, Optional Password As String) As Long   '+                   '+
                          
' Удаляет из таблицы определённый индекс
On Error GoTo e

    Dim i As Long
    Dim cn As New ADODB.Connection
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & _
        BAccess$ & ";" & IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & _
        Trim$(Password$) & ";", ""
    Dim rs As New ADODB.Recordset
    Set rs = New ADODB.Recordset
    rs.Open "SELECT * FROM " & "[" & DBTable & "]", cn, adOpenKeyset, adLockOptimistic
    rs.Move IndexRecord
    rs.Delete
    rs.Update
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
DelRecordFromTable = 0
Exit Function
e:
    escriptionLastError = Err.Description
    Debug.Print Err.Description
    elRecordFromTable = Err.Number
    Set cn = Nothing
    Set rs = Nothing
End Function


Public Function ClearTable(DataBasePath As String, Table As String, _
                           Optional Password As String) As Long  '+
'Очищает таблицу в базе
'При успехе возвращает 0, иначе номер ошибки
On Error GoTo e
    Dim cn As New ADODB.Connection
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & _
        ataBasePath$ & ";" & IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & _
        Trim$(Password$) & ";", ""
    Dim rs As New ADODB.Recordset
    rs.Open "SELECT * FROM " & "[" & Table & "]", cn, adOpenKeyset, adLockOptimistic
    While Not rs.EOF
         rs.Delete
        rs.MoveNext
    Wend
    Set rs = Nothing
    Set cn = Nothing
    ClearTable = 0
Exit Function
e:
    ClearTable = Err.Number
    Debug.Print Err.Description
    escriptionLastError = Err.Description
    On Error GoTo 0: On Error Resume Next
    Set rs = Nothing
    Set cn = Nothing
End Function

Public Function AddColumn(DataBasePath As String, Table As String, NewColumn As String, _
                          VarType As ADOX.DataTypeEnum, _
                          Optional ColumnDefinedSize As Long = 0, _
                          Optional Password As String) As Long '+
'Добавляет столбец к таблице в базе
'При успехе возвращает 0, иначе номер ошибки

'VarType            Code    escription
'adBigInt           20      Indicates an eight-byte signed integer (DBTYPE_I8).
'adBinary           128     Indicates a binary value (DBTYPE_BYTES).
'adBoolean          11      Indicates a boolean value (DBTYPE_BOOL).
'adBSTR             8       Indicates a null-terminated character string (Unicode) (DBTYPE_BSTR).
'adChapter          136     Indicates a four-byte chapter value that identifies rows in a child rowset (DBTYPE_HCHAPTER).
'adChar             129     Indicates a string value (DBTYPE_STR).
'adCurrency         6       Indicates a currency value (DBTYPE_CY). Currency is a fixed-point number with four digits to the right of the decimal point. It is stored in an eight-byte signed integer scaled by 10,000.
'adDate             7       Indicates a date value (DBTYPE_DATE). A date is stored as a double, the whole part of which is the number of days since December 30, 1899, and the fractional part of which is the fraction of a day.
'adDBDate           133     Indicates a date value (yyyymmdd) (DBTYPE_DBDATE).
'adDBTime           134     Indicates a time value (hhmmss) (DBTYPE_DBTIME).
'adDBTimeStamp      135     Indicates a date/time stamp (yyyymmddhhmmss plus a fraction in billionths) (DBTYPE_DBTIMESTAMP).
'adDecimal          14      Indicates an exact numeric value with a fixed precision and scale (DBTYPE_DECIMAL).
'adDouble           5       Indicates a double-precision floating-point value (DBTYPE_R8).
'adEmpty            0       Specifies no value (DBTYPE_EMPTY).
'adError            10      Indicates a 32-bit error code (DBTYPE_ERROR).
'adFileTime         64      Indicates a 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601 (DBTYPE_FILETIME).
'adGUID             72      Indicates a globally unique identifier (GUID) (DBTYPE_GUID).
'adIDispatch        9       Indicates a pointer to an IDispatch interface on a COM object (DBTYPE_IDISPATCH).
'Note               -       This data type is currently not supported by ADO. Usage may cause unpredictable results.
'adInteger          3       Indicates a four-byte signed integer (DBTYPE_I4).
'adIUnknown         13      Indicates a pointer to an IUnknown interface on a COM object (DBTYPE_IUNKNOWN).
'adLongVarBinary    205     Indicates a long binary value (Parameter object only).
'adLongVarChar      201     Indicates a long string value (Parameter object only).
'adLongVarWChar     203     Indicates a long null-terminated Unicode string value (Parameter object only).
'adNumeric          131     Indicates an exact numeric value with a fixed precision and scale (DBTYPE_NUMERIC).
'adPropVariant      138     Indicates an Automation PROPVARIANT (DBTYPE_PROP_VARIANT).
'adSingle           4       Indicates a single-precision floating-point value (DBTYPE_R4).
'adSmallInt         2       Indicates a two-byte signed integer (DBTYPE_I2).
'adTinyInt          16      Indicates a one-byte signed integer (DBTYPE_I1).
'adUnsignedBigInt   21      Indicates an eight-byte unsigned integer (DBTYPE_UI8).
'adUnsignedInt      19      Indicates a four-byte unsigned integer (DBTYPE_UI4).
'adUnsignedSmallInt 18      Indicates a two-byte unsigned integer (DBTYPE_UI2).
'adUnsignedTinyInt  17      Indicates a one-byte unsigned integer (DBTYPE_UI1).
'adUserDefined      132     Indicates a user-defined variable (DBTYPE_UDT).
'adVarChar          204     Indicates a binary value (Parameter object only).
'adVariant          200     Indicates a string value (Parameter object only).
'adVarNumeric       12      Indicates an Automation Variant (DBTYPE_VARIANT).
'adVarWChar         139     Indicates a numeric value (Parameter object only).
'adWChar            202     Indicates a null-terminated Unicode character string (Parameter object only).
'adVarBinary        130     Indicates a null-terminated Unicode character string (DBTYPE_WSTR).
On Error GoTo e
 Dim ct As ADOX.Catalog
 Set ct = New ADOX.Catalog
 ct.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & _
   ataBasePath$ & ";" & IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & _
   Trim$(Password$) & ";", ""
    ct.Tables(Table).Columns.Append NewColumn, VarType, ColumnDefinedSize
   Set ct = Nothing
   AddColumn = 0
   Exit Function
e:
    AddColumn = Err.Number
    Debug.Print Err.Description
    escriptionLastError = Err.Description
    On Error GoTo 0: On Error Resume Next
    Set ct = Nothing
End Function


Public Function ReNameColumn(DataBasePath As String, Table As String, OldColumn As String, _
                             NewColumn As String, _
                             Optional Password As String) As Long '+
                          
'Переименовывает столбец в таблице в базе данных
'При успехе возвращает 0, иначе номер ошибки
On Error GoTo e
 Dim ct As ADOX.Catalog
 Dim MyColumn As ADOX.Column

 Set ct = New ADOX.Catalog
 
 ct.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0ata Source=" & _
   ataBasePath$ & ";" & IIf(Trim(Password) <> "", "Jet OLEDB:Database Password=" & _
   Trim$(Password$) & ";", ""
    
    Set MyColumn = ct.Tables(Table).Columns(OldColumn)
    MyColumn.name = NewColumn
 
   Set cl = Nothing
   Set MyColumn = Nothing
   ReNameColumn = 0
   Exit Function
e:
    ReNameColumn = Err.Number
    Debug.Print Err.Description
    escriptionLastError = Err.Description
    On Error GoTo 0: On Error Resume Next
    Set cl = Nothing
    Set MyColumn = Nothing
End Function


'==============================================================================
'= Ещё всякие полезности ... ================================================
'==============================================================================

Public Sub FastSwap(First, Second)
    First = First Xor Second
    Second = Second Xor First
    First = First Xor Second
End Sub

Public Sub QuickSort(SortArray(), Low As Long, High As Long)
  Dim RandIndex As Long, Partition As Variant
  Dim i As Long, j As Long
   
  If Low < High Then
    If Abs(High - Low) = 1 Then 'Abs заюзан опять-таки из-за возможности отриц. индексов
      ' Если у нас два элемента в куске, то правильно их расставляем
      ' и прекращаем рекурсию:
      If SortArray(Low) > SortArray(High) Then FastSwap SortArray(Low), SortArray(High)
    Else 'Нет, больше двух элементов в куске!
      ' Выбираем случайный элемент, двигаем его в конец:
      RandIndex = RandInt(Low, High)
      FastSwap SortArray(High), SortArray(RandIndex)
      Partition = SortArray(High)
      Do
        ' Идём с обоих сторон по направлению к "центральному":
        i = Low: j = High
        Do While (i < j) And (SortArray(i) <= Partition)
          i = i + 1
        Loop
        Do While (j > i) And (SortArray(j) >= Partition)
          j = j - 1
        Loop
        ' Если мы не достигли "центрального", это значит, что два
        ' элемента любой стороне в неправильном порядке, меняем их:
        If i < j Then FastSwap SortArray(i), SortArray(j)
      Loop While i < j

      ' Двигаем центральный обратно на его место в массиве:
      FastSwap SortArray(i), SortArray(High)
       
      ' Рекурсивно вызываемся (передаём сначала меньший кусок, чтобы занять
      ' меньше стекового пространства):
      If (i - Low) < (High - i) Then
        QuickSort SortArray(), Low, i - 1
        QuickSort SortArray(), i + 1, High
      Else
        QuickSort SortArray(), i + 1, High
        QuickSort SortArray(), Low, i - 1
      End If
    End If
  End If
End Sub

Public Function RandInt(Lower As Long, Upper As Long) As Long
  'Возвращает случайное целое в промежутке от Lower до Upper включительно.
  RandInt = Int(Rnd * (Upper - Lower + 1)) + Lower
End Function

Public Function DetermineDirectory(inputString As String) As String
Dim Pos As Integer
    Pos = InStrRev(inputString, "\", , vbTextCompare)
    etermineDirectory = Mid(inputString, 1, Pos)
End Function

Public Function GetIndexByString(strToFind As String, sArray() As String) As Long
'Находит в массиве строку и возвращает её индекс, если не нашли -1
    Dim i As Long
    For i = LBound(sArray) To UBound(sArray)
        If sArray(i) = strToFind Then
            GetIndexByString = i
            Exit Function
        End If
    Next i
    GetIndexByString = -1
End Function

Public Function Array2HTML(sArray, Optional PervayaStrokaZagolovok As Boolean = False) As String  '+
' Из двухмерного массива формирует html код таблицы
Dim myIndex1 As Long, myIndex2 As Long
On Error GoTo e
'Формируем заголовок
HtmlCode$ = HtmlCode$ & "<html>" & vbCrLf
HtmlCode$ = HtmlCode$ & "<meta http-equiv=content-type content=" & Chr$(34) & "text/html; charset=windows-1251" & Chr$(34) & ">" & vbCrLf
HtmlCode$ = HtmlCode$ & "<table border=" & Chr$(34) & "1" & Chr$(34) & " style=" & Chr$(34) & "font-size:9pt;" & Chr$(34) & ">" & vbCrLf
HtmlCode$ = HtmlCode$ & "<tr bgcolor=" & Chr$(34) & "#cccccc" & Chr$(34) & ">" & vbCrLf
If PervayaStrokaZagolovok = True Then
    For myIndex1 = 0 To UBound(sArray, 2)  'Строим заголовк столбцов
        HtmlCode$ = HtmlCode$ & "<td width=" & Chr$(34) & "100" & Chr$(34) & ">" & vbCrLf
        HtmlCode$ = HtmlCode$ & "<p> &nbsp;" & sArray(0, myIndex1) & "</p>" & vbCrLf
        HtmlCode$ = HtmlCode$ & "</td>" & vbCrLf
    Next myIndex1
End If
HtmlCode$ = HtmlCode$ & "</tr>" & vbCrLf
For myIndex1 = IIf(PervayaStrokaZagolovok = True, 1, 0) To UBound(sArray, 1)
    HtmlCode$ = HtmlCode$ & "<tr>" & vbCrLf
    For myIndex2 = 0 To UBound(sArray, 2)
         HtmlCode$ = HtmlCode$ & "<td width=" & Chr$(34) & "100" & Chr$(34) & ">" & vbCrLf
         HtmlCode$ = HtmlCode$ & "<p> &nbsp;" & sArray(myIndex1, myIndex2) & "</p>" & vbCrLf
         HtmlCode$ = HtmlCode$ & "</td>" & vbCrLf
    Next myIndex2
    HtmlCode$ = HtmlCode$ & "</tr>" & vbCrLf
Next myIndex1
HtmlCode$ = HtmlCode$ & "</table>" & vbCrLf
HtmlCode$ = HtmlCode$ & "</html>" & vbCrLf
Array2HTML = HtmlCode$
Exit Function
e:
Array2HTML = ""
DescriptionLastError = Err.Description
Debug.Print Err.Description
End Function

Public Function ExportArray2XL(sArray() As String, Optional FirstItemIsBold As Boolean = True) As Long     '+
' Экспортирует с массива в Excel
Dim myIndex As Integer, myColumns As Integer
Dim ApExcel As Object
Dim MyCol As String

Set ApExcel = CreateObject("Excel.application"

ApExcel.Visible = True
ApExcel.Workbooks.Add

For myIndex = 0 To UBound(sArray, 1)
    For myColumns = 0 To UBound(sArray, 2)
        ApExcel.Cells(myIndex + 1, myColumns + 1).formula = sArray(myIndex, myColumns)
        If FirstItemIsBold = True And myIndex = 0 Then
            ApExcel.Cells(myIndex + 1, myColumns + 1).Font.Bold = True
            ApExcel.Cells(myIndex + 1, myColumns + 1).interior.colorindex = 36
            ApExcel.Cells(myIndex + 1, myColumns + 1).WrapText = True
        End If
    Next myColumns
Next myIndex

ExportArray2XL = 0
End Function

Public Sub FromListView2Array(ListView As ListView, ReturnArray() As String, _
                            Optional s_zagolokom_stolbcov As Boolean = False) '+
'Формируем из ListView двухмерный массив ReturnArray
    
    Dim i As Integer, j As Integer
    If s_zagolokom_stolbcov = True Then
        ReDim ReturnArray(ListView.ListItems.Count, ListView.ColumnHeaders.Count - 1)
        For i = 1 To ListView.ColumnHeaders.Count
            ReturnArray(0, i - 1) = ListView.ColumnHeaders(i).Text
        Next i
    Else
        ReDim ReturnArray(ListView.ListItems.Count - 1, ListView.ColumnHeaders.Count - 1)
    End If
    
    For i = 1 To ListView.ListItems.Count
        For j = 1 To ListView.ColumnHeaders.Count
            If j = 1 Then
                ReturnArray(i - IIf(s_zagolokom_stolbcov = True, 0, 1), j - 1) = ListView.ListItems(i)
            Else
                ReturnArray(i - IIf(s_zagolokom_stolbcov = True, 0, 1), j - 1) = ListView.ListItems(i).SubItems(j - 1)
            End If
        Next j
    Next i
End Sub

Public Sub FromArray2ListView(ListView As ListView, sArrayTable() As String)
'Загружаем в ListView данные из двухмерного массива

        For q = 0 To UBound(sArrayTable, 1)
            Set lvItm = ListView.ListItems.Add(, , sArrayTable(q, 0))
            For i = 1 To UBound(sArrayTable, 2)
                lvItm.SubItems(i) = sArrayTable(q, i)
            Next i
        Next q
End Sub

Public Function IsEmptyArray(sArray()) As Boolean
'Если массив пустой, возвращает False, иначе True

Dim Count As Long
On Error GoTo e
    Count = UBound(sArray)
    IsEmptyArray = False
Exit Function
e:
    IsEmptyArray = True
End Function

Public Sub QuickSortNonRecursive(SortArray())
  Dim i As Long, j As Long, lb As Long, ub As Long
  Dim stack() As QuickStack, stackpos As Long, ppos As Long, pivot As Variant
   
  ReDim stack(1 To 1024)
  stackpos = 1

  stack(1).Low = LBound(SortArray)
  stack(1).High = UBound(SortArray)
   
  Do
    'Взять границы lb и ub текущего массива из стека.
    lb = stack(stackpos).Low
    ub = stack(stackpos).High
    stackpos = stackpos - 1
     
    Do
      'Шаг 1. Разделение по элементу pivot
      ppos = (lb + ub) \ 2
      i = lb: j = ub: pivot = SortArray(ppos)
       
      Do
        Do While SortArray(i) < pivot: i = i + 1: Loop
        Do While pivot < SortArray(j): j = j - 1: Loop
         
        If i <= j Then
          Swap SortArray(i), SortArray(j)
          i = i + 1
          j = j - 1
        End If
      Loop While i <= j
       
      'Сейчас указатель i указывает на начало правого подмассива,
      'j - на конец левого lb ? j ? i ? ub.
      'Возможен случай, когда указатель i или j выходит за границу массива
       
      'Шаги 2, 3. Отправляем большую часть в стек  и двигаем lb,ub
       
      If i < ppos Then   'правая часть больше
        If i < ub Then
          stackpos = stackpos + 1
          stack(stackpos).Low = i
          stack(stackpos).High = ub
        End If
        ub = j          'следующая итерация разделения будет работать с левой частью
      Else
        If j > lb Then
          stackpos = stackpos + 1
          stack(stackpos).Low = lb
          stack(stackpos).High = j
        End If
        lb = i
      End If
    Loop While lb < ub
  Loop While stackpos
End Sub