Программирование на Visual Basic

Этот пример покажет Вам как правильно определить различные свойства папок в Windows. Вы также сможете прочитать свойства томов, системных папок и т.п.

' Прочитать все свойства папки
'   f1.DateCreate - дата создания папки
'
Private Sub butProperties_Click()
On Error GoTo 999
    Dim fs, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f1 = fs.GetFolder(Me.myFolder)
    Me.progress = _
        "Name: "  f1.Name  vbCrLf  _
        "Path: "  f1.Path  vbCrLf  _
        "Attributes: "  f1.Attributes  vbCrLf  _
        "DateCreated: "  f1.DateCreated  vbCrLf  _
        "LastAccessed: "  f1.DateLastAccessed  vbCrLf  _
        "LastModified: "  f1.DateLastModified  vbCrLf  _
        "IsRootFolder: "  f1.IsRootFolder  vbCrLf  _
        "ShortName: "  f1.ShortName  vbCrLf  _
        "ShortPath: "  f1.ShortPath  vbCrLf  _
        "Size: "  f1.Size  vbCrLf  _
        "Type: "  f1.Type  vbCrLf  _
        "fs.FolderExists('c:\')="  fs.FolderExists("c:\")  vbCrLf  _
        ""
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Получение имени специальной папки
'   fs.GetSpecialFolder(0) - 'c:\windows'
'   fs.GetSpecialFolder(1) - 'c:\windows\system'
'   fs.GetSpecialFolder(2) - 'c:\windows\temp
' Получение других имен
'   fs.GetFolder(".") - текущая папка
'   fs.GetFolder("..") - корневая папка
' Проверки для c:
'   fs.FolderExists("c:\") = True - есть на диске
'   fs.GetFolder("c:\").IsRootFolder = True - корневая папка
'
Private Sub butViewSpecFolder_Click()
On Error GoTo 999
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    Me.progress = _
        "Папка Windows: "  fs.GetSpecialFolder(0)  vbCrLf  _
        "Папка System: "  fs.GetSpecialFolder(1)  vbCrLf  _
        "Папка Temp: "  fs.GetSpecialFolder(2)  vbCrLf  _
        "Текущая папка: "  fs.GetFolder(Me.myFolder  "\.")  vbCrLf  _
        "Родительская папка: "  fs.GetFolder(Me.myFolder  "\..")  vbCrLf  _
        ""
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Получить список файлов
'   fs.GetFolder(".").Files
'
Private Sub butViewFiles_Click()
On Error GoTo 999
    Dim fs, fc, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fc = fs.GetFolder(Me.myFolder).Files
    Me.progress = "Count="  fc.Count  vbCrLf
    For Each f1 In fc
        Me.progress = Me.progress  f1.Name  vbCrLf
    Next

    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Получить список подчиненных папок
'   fs.GetFolder(".").SubFolders
'
Private Sub butViewSubFolders_Click()
On Error GoTo 999
    Dim fs, fc, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fc = fs.GetFolder(Me.myFolder).SubFolders
    Me.progress = "Count="  fc.Count  vbCrLf
    For Each f1 In fc
        Me.progress = Me.progress  f1.Name  vbCrLf
    Next

    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Прочитать все свойства папки
'   f1.DateCreate - дата создания папки
'
Private Sub butDrive_Click()
On Error GoTo 999
    Dim fs, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f1 = fs.GetFolder(Me.myFolder).drive
    Me.progress = _
        "DriveLetter: "  f1.DriveLetter  vbCrLf  _
        "AvailableSpace: "  f1.AvailableSpace  vbCrLf  _
        "DriveType: "  f1.DriveType  vbCrLf  _
        "FileSystem: "  f1.FileSystem  vbCrLf  _
        "FreeSpace: "  f1.FreeSpace  vbCrLf  _
        "IsReady: "  f1.IsReady  vbCrLf  _
        "Path: "  f1.Path  vbCrLf  _
        "SerialNumber: "  f1.SerialNumber  vbCrLf  _
        "ShareName: "  f1.ShareName  vbCrLf  _
        "TotalSize: "  f1.TotalSize  vbCrLf  _
        "VolumeName: "  f1.VolumeName
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

'==============================================================
Private Sub Form_Open(Cancel As Integer)
    ' Устанавливаем каталог
    ChDir Application.CurrentProject.Path
    ' Определение имени новой папки
    Me.myFolder = Application.CurrentProject.Path
End Sub

06. В таблицах Access можно использовать разные цвета полей, для этого нужно знать их форматирование. Пример. !\ [Красный] или dd.mm.yyyy[Синий];;;"Нет даты". Для более детальной информации откройте этот пример.

08. Очень часто встречается так, что одна таблица подчиняется другой. Например, накладные, а у них есть спецификация. Если создать соотношение один ко многим, то у таблицы появляется поле [+]. Нажав на него, можно увидеть подчиненную таблицу.

03. Если Вас не устраивает однотипный цвет таблиц запросов, то использование этого метода позволит вам раскрасить отдельные поля запроса.

'==============================================================
'   Установить формат поля
Private Sub butExecute_Click()
Dim dbs As Database, obj As Object
    On Error GoTo 999
        Set dbs = CurrentDb
        Set obj = dbs.QueryDefs("Запрос 03").Fields("Сумма03")
        SetFieldProperty obj, "Format", dbChar, "0.00;0.00;0.00;0[Red]"
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "Изменение поля"
    Err.Clear
End Sub

'==============================================================
'   Удалить формат поля
Private Sub butDelProp_Click()
Dim dbs As Database, obj As Object
    On Error GoTo 999
        Set dbs = CurrentDb
        Set obj = dbs.QueryDefs("Запрос 03").Fields("Сумма03")
        SetFieldProperty obj, "Format", dbChar, "0;0;0"
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "Удаление поля"
    Err.Clear
End Sub

'==============================================================
'   Установить свойство поля запроса
Private Sub SetFieldProperty(obj As Object, _
        prpName As String, _
        prpType As Integer, _
        prpValue As Variant)
Dim prp As Variant
    On Error GoTo 999
    obj.Properties(prpName) = prpValue
    obj.Properties.Refresh
    MsgBox "Свойство изменено!", vbExclamation, "Свойства"
    Exit Sub
999:
    Err.Clear
    Set prp = obj.CreateProperty(prpName, prpType, prpValue)
    obj.Properties.Append prp
    obj.Properties.Refresh
End Sub

При разработке интерфейса Вам может потребоваться погасить или отобразить некоторую панель меню. Чтобы не копаться в справочниках и интернете этот пример поможет загрузить все меню в таблицу. Таким образом, вы будете знать все названия панелей меню.

'==============================================================
'  Загружаем все панели в запрос
Private Sub Form_Open(Cancel As Integer)
Dim cbr As CommandBar, s As String, dbs As Database
    On Error GoTo 999
    Set dbs = CurrentDb 'Выбор базы данных
    dbs.Execute "DELETE * FROM [Пример 03]" 'Удаляем все записи
    For Each cbr In Application.CommandBars 'Просматриваем все меню
       If cbr.RowIndex = 0 Then 'Выбираем панели
            'Составляем запрос на добавление
            s = "INSERT INTO [Пример 03] ( Вкл, Имя, Перевод ) SELECT "  _
                cbr.Visible  " AS Вкл, """  _
                cbr.Name  """ AS Имя,"""  _
                cbr.NameLocal  """ AS Перевод;"
            dbs.Execute s 'Добавляем в таблицу меню
       End If
    Next
    Me.Requery 'Изменяем запрос
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

'==============================================================
'  Отображаем панель
Private Sub Вкл_Click()
    If Me.Вкл = True Then
        DoCmd.ShowToolbar Me.Перевод, acToolbarYes
    Else
        DoCmd.ShowToolbar Me.Перевод, acToolbarNo
    End If
End Sub

Данный пример определяет коды клавиш меню для быстрого запуска команд. Например, чтобы вызвать пункт меню "Сервис\Схема данных" достаточно запустить команду: CommandBars("Menu Bar").FindControl(, 523, , , True).Execute или CommandBars("Tools").Controls("С&хема данных...").Execute

Private Sub myBar_AfterUpdate()
    
    ' Гасим все меню
    On Error Resume Next
    Dim cbr As CommandBar
    For Each cbr In Application.CommandBars
        If cbr.Visible Then cbr.Visible = False
    Next
    Err.Clear
    
    On Error GoTo 999
    ' Удаляем все из базы данных
    Dim dbs As Database
    Set dbs = CurrentDb 'Выбор базы данных
    dbs.Execute "DELETE * FROM [Пример 05]" 'Удаляем все записи
    Me.myControlsBar.Requery
    
    
    ' Находим панель
    Set cbr = Application.CommandBars(Me.myBar.Value)  ' Выбираем меню
    cbr.Visible = True
    
    ' Просматриваем панель
    Dim cbc As CommandBarControl
    For Each cbc In cbr.Controls    ' Просматриваем все кнопки
        putControlsBar cbc.Parent.Name, cbc ' Сохраняем кнопку
    Next
    
    ' Перерисовываем форму
    Me.myControlsBar.Requery
    Me.txtMsg.Visible = False ' Гасим сообщение
    
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

Private Function putControlsBar(strParent As String, obj As Object)
Dim cbc As CommandBarControl, s As String
    
    If TypeOf obj Is CommandBarPopup Then
        ' Меню. Сохраняем каждую кнопку меню
        For Each cbc In obj.CommandBar.Controls
            s = strParent  "\"  cbc.Parent.Name
            putControlsBar s, cbc
        Next cbc
    Else
        ' Кнопка. Добавляем ее в таблицу
        InsertString strParent, obj.Caption, obj.ID
    End If
End Function

'==============================================================
'  Вставляем строку в базу данных
Private Function InsertString(strParent As String, strCaption As String, longID As Long)
Dim s As String, dbs As Database, strCommand As String
    On Error Resume Next
    Set dbs = CurrentDb 'Выбор базы данных
    strCommand = "CommandBars(""""Menu Bar"""").FindControl(, "  longID  ", , , True).Execute"
    s = "INSERT INTO [Пример 05] ( Parent, Name, ID, Command ) SELECT """  _
        strParent  """ AS Parent, """  _
        strCaption  """ AS Name,"  _
        longID  " AS ID, """  _
        strCommand  """ AS Command;"
    dbs.Execute s 'Добавляем в таблицу код кнопки
    Debug.Print s
    Err.Clear
    
    ' Сообщаем о работе программы
    DoEvents
    Me.txtMsg.Visible = Not Me.txtMsg.Visible ' Сообщение
End Function

'==============================================================
'  Отобразить схему базы данных
'  (выберите код кнопки и запустите программу)
Private Sub butTools_Click()
    Dim cbc As CommandBarControl
    ' 1 вариант. Запуск по названию
    'CommandBars("Tools").Controls("Схема данных...").Execute
    
    ' 2 вариант. Поиск по коду и проверка для запуска
    'Set cbc = CommandBars("Menu Bar").FindControl(ID:=523, Recursive:=True)
    'If cbc.Visible Then cbc.Execute
    
    ' 3 вариант. Поиск и запуск по коду
    CommandBars("Menu Bar").FindControl(, 523, , , True).Execute
End Sub

При разработке интерфейса Вам может потребоваться использовать правую кнопку мыши для вызова контекстного меню. Как это сделать программным способом смотрите в этом разделе.

Dim WithEvents myCombo As CommandBarComboBox ' Обработка событий

Const strMenu As String = "Правая кнопка"

Private Sub Form_Open(Cancel As Integer)
    ' Определяем название
    On Error Resume Next
    CommandBars.Item(strMenu).Delete
    Err.Clear
    
    ' Создаем панель меню
    On Error GoTo 999
    Dim myBar As CommandBar
    Set myBar = CommandBars.Add(strMenu, msoBarPopup, , False)
    
    ' Добавляем 1 кнопку
    Dim But As CommandBarButton
    Set But = myBar.Controls.Add(msoControlButton)
    With But
        .Style = msoButtonCaption ' Выбираем стандартный тип
        .FaceId = 1 ' Устанавливаем код кнопки
        .Caption = "Кнопка 1" ' Называем кнопку
        .OnAction = "=msgBox('Привет!')" ' Определяем программу
    End With
    
    ' Создаем список в меню
    Set myCombo = myBar.Controls.Add(msoControlDropdown, , 1)
    With myCombo
        .BeginGroup = True
        .Caption = "Cписок: "
        .Style = msoComboLabel
        .AddItem "Строка 1"
        .AddItem "Строка 2"
        .ListIndex = 2 ' Устанавливаем 2 вариант
        .DropDownWidth = -1 ' Выбираем ширину по самому длинному
    End With
    
    ' Добавляем кнопки меню из других панелей
    ' (для нахождения кодов смотрите пример 05)
    '
    With CommandBars("Menu Bar")
        .FindControl(, 523, , , True).Copy myBar ' Схема данных
        .FindControl(, 210, , , True).Copy myBar ' Сортировка по возрастанию
        .FindControl(, 211, , , True).Copy myBar ' Сортировка по убыванию
        .FindControl(, 19, , , True).Copy myBar ' Копировать в буфер
    End With
   
    ' Просмотр данных из текущей позиции
    ' myBar.ShowPopup
    Exit Sub
999:
    MsgBox Err.Description
End Sub

'==============================================================
'  Отключение
Private Sub butOld_Enter()
    Me.ShortcutMenuBar = ""
End Sub

'==============================================================
'  Включение меню
Private Sub butNew_Enter()
    Me.ShortcutMenuBar = strMenu
End Sub

'==============================================================
'  Включение меню
Private Sub myCombo_Change(ByVal ctrl As CommandBarComboBox)
    MsgBox "Текст: "  ctrl.Text
End Sub

05. Открыть запросы SELECT базы данных можно по разному. Эти функции показывают, как можно это сделать из разных библиотек.

Option Compare Database
Option Explicit

'==============================================================
' ADO. Использование запросов
Private Sub butADO_Click()
Dim rst As ADODB.Recordset
    
    ' Включаем обработку ошибок
    On Error GoTo 999
    
    ' Создание запроса
    Set rst = New ADODB.Recordset
    
    ' Заполняем запрос
    With rst
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic ' Возможно редактирование
        .Source = "SELECT * from [Пример 04]"
        
        .Open , CurrentProject.Connection, , , adCmdText
        If rst.RecordCount Then
            .MoveLast ' Заполнение запроса и расчет кол-ва записей
            .MoveFirst ' Начнем с первой записи
            Do Until .EOF
                ' Изменение записей
                rst!Описание = "ADO. Пример 05"
                rst.Update
                rst.MoveNext
            Loop
        End If
    End With
    
    ' Отображаем список
    Me.myList.RowSource = "ADODB. Изменение сделаны;Всего записей: "  Format(rst.RecordCount, "000")
    
    ' Конец просмотра
    rst.Close
    Set rst = Nothing
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

'==============================================================
' DAO. Использование запросов
Private Sub butDAO_Click()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim i As Long
    
    ' Включаем обработку ошибок
    On Error GoTo 999
    
    ' Создание запроса
    Set dbs = CurrentDb ' Текущая база данных
    Set rst = dbs.OpenRecordset("SELECT * from [Пример 04]")
    
    ' Заполняем запрос
    With rst
        If .RecordCount Then
            .MoveLast ' Заполнение запроса и расчет кол-ва записей
            .MoveFirst ' Начнем с первой записи
            For i = 0 To .RecordCount - 1
                ' Редактирование записей
                rst.Edit
                rst!Описание = "DAO. Пример 05"
                rst.Update
                rst.MoveNext
            Next
        End If
    End With
    
    ' Отображаем список
    Me.myList.RowSource = "DAO. Изменения сделаны;Всего записей: "  Format(rst.RecordCount, "000")
    
    ' Конец просмотра
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

06. Файл UDL - это файл строки соединения с базой данных. Эти функции показывают, как можно его создать из VBA

Option Compare Database
Option Explicit
'==============================================================
' ADO. Читаем файл UDL
Private Sub butRead_Click()
    
    ' Строка файла udl
    Dim strUdl As String ' Файл
    strUdl = Application.CurrentProject.Path  "\la_ado.udl"
    
    ' Открываем файл
    Dim fs, f
    Const ForReading = 1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.OpenTextFile(strUdl, ForReading, False, -1) ' Читаем файл Unicode
   
    ' Читаем данные из файла
    Dim strCnn As String
    strCnn = f.read(FileLen(strUdl))
    
    ' Закрываем файл
    f.Close
    Set f = Nothing
    Set fs = Nothing
    
    ' Разбор строки для списка
    Dim arCnn ' Массив строк
    arCnn = Split(strCnn, vbCrLf, 5, vbBinaryCompare)
    
    ' Заполнение списка
    Dim i As Long
    Me.myList.RowSource = ""
    For i = 0 To UBound(arCnn) - 1
        Me.myList.RowSource = Me.myList.RowSource  arCnn(i)  ";"
    Next i
End Sub

'==============================================================
' ADO. Создаем файл UDL
Private Sub butWrite_Click()
    ' Строка файла udl
    Dim strUdl As String ' Файл
    strUdl = Application.CurrentProject.Path  "\la_ado1.udl"
    
    ' Открываем файл
    Dim fs, f
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.CreateTextFile(strUdl, True, True) ' Файл, Переписать, Unicode
    
    ' Создаем строку для файла
    ' 2 строки информации, 3 для соединения (см. Пример 02)
    '"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\Access WebServer\subscribe\_mdb\la_array.mdb;Mode=Read|Write|Share Deny None;Persist Security Info=False;Jet OLEDB:Don't Copy Locale on Compact=True"

    Dim strCnn As String
    strCnn = "[oledb]"  vbCrLf  _
             "; Everything after this line is an OLE DB initstring"  vbCrLf  _
             "Provider=Microsoft.Jet.OLEDB.4.0;Mode=Read|Write|Share Deny None;Persist Security Info=False"  vbCrLf
    f.write strCnn
    
    ' Закрываем файл
    f.Close
    Set f = Nothing
    Set fs = Nothing
    MsgBox "Файл la_ado1.udl создан", vbExclamation, "Лидер Access"
End Sub

При разработке интерфейса Вам может потребоваться погасить или отобразить некоторые кнопки меню. Этот пример показывает, как можно это сделать.

'==============================================================
'    Вставить кнопку
Private Sub butInsert_Click()
Dim But As CommandBarButton 'Mso9.dll
    On Error GoTo 999
    Set But = Application.CommandBars("Мое меню").Controls.Add(msoControlButton)
    With But
        .BeginGroup = True 'Начинаем размещение с начала группы
        .FaceId = 1 'Устанавливаем код кнопки
        .Style = msoButtonCaption 'Выбираем стандартный тип
        .Caption = "Привет" 'Называем кнопку
        .TooltipText = "Мой привет всем!" 'Всплывающая подсказка
        .OnAction = "=msgbox(""Привет всем!"")" 'Моя программа
    End With
    Exit Sub
999:
    Err.Clear
End Sub

'==============================================================
'  Удалить кнопку
Private Sub butDelete_Click()
    On Error GoTo 999
    Application.CommandBars("Мое меню").Controls("Привет").Delete
999:
    Err.Clear
End Sub