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

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 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

14. Бывает при разработке интерфейса необходимо не только провести сортировку формы, но и сохранить текущую запись. Это делается с помощью этого кода

'    Сортировка
Private Sub butSort_Click()
Dim frm As Form, rst As Recordset, myBook As String
    On Error Resume Next
    Set frm = [Form_Пример 14 пдч] 'Выбираем форму
    
    myBook = frm.Книга
    frm.OrderBy = "[Книга] asc" 'Сортируем по возрастанию
    frm.OrderByOn = True 'Включаем сортировку
    
    'Ищем запись
    Set rst = frm.Recordset
    rst.FindFirst "[Книга]='"  myBook  "'"
    frm.Bookmark = rst.Bookmark   'Возвращаем позицию
    Err.Clear
End Sub

'==============================================================
'    Сортировка
Private Sub Form_Open(Cancel As Integer)
Dim frm As Form
    Set frm = [Form_Пример 14 пдч] 'Выбираем форму
    frm.OrderBy = "[Книга] desc" 'Сортируем по убыванию
    frm.OrderByOn = True 'Включаем сортировку
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

12. При разработке баз данных очень часто встречаются случаи, когда необходимо автоматическим способом заполнить поля в форме. Это показано в этом примере (..\15 Формы\la_from2.accdb\12. Заполнение реквизитов предприятия)

'==============================================================
' Заполнение реквизитов
Private Sub allFirms_AfterUpdate()
Dim rst As Recordset
    On Error GoTo 999
    Set rst = CurrentDb.OpenRecordset("SELECT * FROM [Фирмы] WHERE [Фирма]='"  Me.allFirms  "'")
    If rst.RecordCount  0 Then
        With rst
            'Форму Вы можете связать с таблицей
            Me.Фирма = rst!Фирма
            Me.Банк = rst!Банк
            Me.Счет = rst!Счет
            Me.КорСЧЕТ = rst!КорСчет
        End With
    End If
    rst.Close
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

' Определяем максимальный номер документа
Private Sub Form_Current()
    If Me.NewRecord = True Then
       Me.Nдок.DefaultValue = 1 + funGetMaxNumber("SELECT Max([Nдок]) as NN FROM [Пример 12]")
    End If
End Sub

'==============================================================
' Получаем максимальное число
Function funGetMaxNumber(sSQL As String) As Long
Dim dbs As Database, rst As Recordset
    funGetMaxNumber = 0
    On Error GoTo 999
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(sSQL)
    If rst.RecordCount  0 Then
        funGetMaxNumber = rst![NN]
    End If
    rst.Close
    Exit Function
999:
    Err.Clear
End Function

У Microsoft Office есть специальный диалог открытия файлов, который имеет много интересных свойств. Он лучше диалога Windows. В этом примере показано как можно его использовать.

Private Sub butSelectFile_Click()
    ' Включите библитеку libDialogFiles
    Me.strFilePath = fOfficeGetFile("Выберите файл", "C:", "*.txt")
End Sub
'#Const constOffice2000 = 0 ' Для Microsoft Office 97
#Const constOffice2000 = 1 ' Для Microsoft Office 2000

Private Declare Function funOfficeGetFile _
 Lib "msaccess.exe" Alias "#56" _
 (gfni As accOfficeGetFileNameInfo, fOpen As Integer) As Long

' OfficeGetFileName flags
Public Const flagNoChangeDir = H2    ' Не меняет каталог пользователя
Public Const flagDirectoryOnly = H20 ' Открывает только папку

Public Type accOfficeGetFileNameInfo
    hwndOwner As Long
    strAppName As String * 255
    strDlgTitle As String * 255
    strOpenTitle As String * 255
    strFile As String * 4096
    strInitialDir As String * 255
    strFilter As String * 255
    lngFilterIndex As Long
    lngView As Long
    lngFlags As Long
End Type

'Функция открытия файла
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( _
        FILENAME As OPENFILENAME) As Boolean

'Функция сохранения файла
Declare Function apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" ( _
        FILENAME As OPENFILENAME) As Boolean

'Структура файла, описание дано ниже
Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As Long
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type

'Флажки для параметра OPENFILENAME.Flags
'  (например, OFN_FILEMUSTEXIST Or OFN_READONLY)
Const OFN_READONLY = H1
Const OFN_OVERWRITEPROMPT = H2
Const OFN_HIDEREADONLY = H4
Const OFN_NOCHANGEDIR = H8
Const OFN_SHOWHELP = H10
Const OFN_ENABLEHOOK = H20
Const OFN_ENABLETEMPLATE = H40
Const OFN_ENABLETEMPLATEHANDLE = H80
Const OFN_NOVALIDATE = H100
Const OFN_ALLOWMULTISELECT = H200
Const OFN_EXTENSIONDIFFERENT = H400
Const OFN_PATHMUSTEXIST = H800
Const OFN_FILEMUSTEXIST = H1000
Const OFN_CREATEPROMPT = H2000
Const OFN_SHAREAWARE = H4000
Const OFN_NOREADONLYRETURN = H8000
Const OFN_NOTESTFILECREATE = H10000

Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0

' Получение папки для программы
Public Function fOfficeGetFileName( _
 gfni As accOfficeGetFileNameInfo, _
 ByVal fOpen As Integer) As Long
    Dim lngReturn As Long
    With gfni
        .strAppName = RTrim$(.strAppName)  vbNullChar
        .strDlgTitle = RTrim$(.strDlgTitle)  vbNullChar
        .strOpenTitle = RTrim$(.strOpenTitle)  vbNullChar
        .strFile = RTrim$(.strFile)  vbNullChar
        .strInitialDir = RTrim$(.strInitialDir)  vbNullChar
        .lngFilterIndex = 1
        .strFilter = RTrim$(.strFilter)  vbNullChar '"Все файлы (*.*)"  vbNullChar
        lngReturn = funOfficeGetFile(gfni, fOpen)
        
        .strAppName = fTrimNull(.strAppName)
        .strDlgTitle = fTrimNull(.strDlgTitle)
        .strOpenTitle = fTrimNull(.strOpenTitle)
        .strFile = fTrimNull(.strFile)
        .strInitialDir = fTrimNull(.strInitialDir)
        .strFilter = fTrimNull(.strFilter)
    End With
    fOfficeGetFileName = lngReturn
End Function

'Обрезка данных
Private Function fTrimNull(strVal As String) As String
    Dim lngPos As Long
    lngPos = InStr(1, strVal, vbNullChar)
    Select Case lngPos
        Case Is  1:  fTrimNull = Left$(strVal, lngPos - 1)
        Case 0:       fTrimNull = strVal
        Case 1:       fTrimNull = vbNullString
    End Select
End Function

'==============================================================
'   Назначение
'        Открытие окна диалога файлов
'   Параметры:
'        strFilter - строка фильтра
'        strIniFile - файл инициализации
'        strTitleDlg - заголовок окна
'        strDefExt - расширение по умолчанию
'        strCurDir - текущая папка
'
Public Function fGetSaveFileName( _
    hwnd As Long, _
    strFilter As String, _
    strIniFile As String, _
    strTitleDlg As String, _
    strDefExt As String, _
    strCurDir As String) As String
Dim OFNAME As OPENFILENAME 'Назначаем переменную для файла
Dim flag As Boolean

     'Заполним структуру перед вызовом GetOpenFileName
     With OFNAME
         .lStructSize = Len(OFNAME) 'Размер структуры в байтах
         .hwndOwner = hwnd 'Указатель окна
         .lpstrFilter = strFilter 'Фильтр отбора
         .nFilterIndex = 1 'Индекс первой пары строк фильтра
         .lpstrFile = strIniFile  String$(512 - Len(strIniFile), 0) 'Полное имя файла
         .nMaxFile = 511 'Размер буфера файла
         .lpstrFileTitle = String$(512, 0) 'Только имя файла окна
         .nMaxFileTitle = 511 'Размер буфера заголовка
         .lpstrTitle = strTitleDlg 'Заголовок окна диалога
         .flags = OFN_FILEMUSTEXIST 'Типы читаемых файлов
         .lpstrDefExt = strDefExt 'Расширение файла по умолчанию
         .lpstrInitialDir = strCurDir 'Каталог файлов по умолчанию
         .hInstance = 0 'Идентификатор блока данных для OFN_ENABLETEMPLATE
         .lpstrCustomFilter = 0 'Дополнительные фильтры, см. ниже
         .nMaxCustFilter = 0 'не менее 40, 0 - игнорируется
         .nFileOffset = 0 'Определяет смещение имени
         .nFileExtension = 0 'Определяет расширение
         .lCustData = 0 'Для собственных окон
         .lpfnHook = 0 'Указатель на фу��кцию фильтра
         .lpTemplateName = 0 'Собственный диалог
         '*** Старт
         flag = apiGetSaveFileName(OFNAME) 'Общий случай
         If flag Then  'Открываем диалог и находим имя файла
              fGetSaveFileName = Left(.lpstrFile, InStr(.lpstrFile, Chr(0)) - 1)
         Else
              fGetSaveFileName = ""
         End If
    End With
End Function

'==============================================================
'    Выполнение действий
Public Function fOfficeGetFile(strTitle As String, strInitDir As String, strFilter As String, Optional officeFlags As Long) As String
Dim lngFlags As Long
Dim gfni As accOfficeGetFileNameInfo
    
    On Error GoTo 999
    With gfni
        If officeFlags  0 Then .lngFlags = officeFlags
        .strFilter = strFilter
        .strFile = ""
        .strDlgTitle = "Выберите файл"
        .strOpenTitle = ""
        .strInitialDir = strInitDir
        .hwndOwner = Application.hWndAccessApp
    End With
    If fOfficeGetFileName(gfni, -1) = 0 Then
        fOfficeGetFile = Trim(gfni.strFile)
    Else
        fOfficeGetFile = ""
    End If
    Exit Function
999:
    MsgBox Err.Description
    Err.Clear
End Function

02. Данный пример показывает как можно быстро создать документ Word из Microsoft Access. При этом документ будет создаваться в текущей папке, откуда запущено приложение. Также не забудьте создать ссылку на Word: C:\Program Files\Microsoft Office\OFFICE11\MSWORD.OLB

'==============================================================
'  Назначение
'    Создать документ Word в текущей папке
'
Private Sub butExecute_Click()
Dim app As Word.Application  ' Приложение программы
Dim strDOC As String ' Имя файла
    On Error GoTo 999
    ' Назначаем имя документа
    strDOC = Application.CurrentProject.Path  "\"  "la_automat.doc"
    Set app = New Word.Application ' Создаем документ
    app.Visible = False ' Скрываем документ
    app.Documents.Add ' Добавляем документ
    app.Selection.Text = Me.Body ' Вставляем текст
    app.ActiveDocument.SaveAs strDOC ' Сохраняем документ
    app.Quit ' Закрываем документ
    MsgBox "Файл: "  strDOC  " создан!", vbExclamation, "Документ Word"
    ' Назначение ссылки
    With Me.myWordDoc
        .HyperlinkAddress = strDOC ' Создаем ссылку
        .Visible = True ' Отображаем элемент
    End With
    Exit Sub
999:
    MsgBox Err.Description  ' Ошибка
    Err.Clear
    app.Quit
End Sub

07. Использование ключевого слова UPDATE в запросах позволит вам обновить сразу много записей.

Private Sub butExecute_Click()
Dim dbs As Database
    On Error GoTo 999
    Set dbs = CurrentDb
    dbs.Execute "UPDATE [Пример 07] SET [Цена] = [Цена]+"  Me.Delta  ";"
    MsgBox "Цена в таблице [Пример 07] изменена!", vbExclamation
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "Создание поля"
    Err.Clear
End Sub

11. Выделить всю строки в форме возможно, если Вы используете программных код указанный в описании.

Private Sub Form_Current()
Dim N As Long
    On Error Resume Next
    Me.Repaint
    N = Me.SelTop
    If N  1 Then N = 1
    Me.SelTop = N
    Me.SelLeft = 1
    Me.SelWidth = 10
    Me.SelHeight = 1
    Err.Clear
End Sub

06. Этот метод показывает Вам как отобразить рисунок в форме, но не хранить его в таблице базы.

'==============================================================
'   Изменение рисунка
Private Sub Form_Current()
Dim s As String
    On Error GoTo 999
    s = Application.CodeProject.Path 'Каталог программы
    myPicture.Picture = s  "\"  Me.Рисунок 'Вставляем новый рисунок
    Me.Рисунок.Visible = False 'Гасим рисунок
    Exit Sub
999:
    Err.Clear
    Me.Рисунок.Visible = True  'Показываем поле
    myPicture.Picture = "" 'Нет рисунка
End Sub