Программирование на Visual Basic | Microsoft Access, Excel, Word
Leadersoft.ru

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

Microsoft Access, Excel, Word

В этом разделе сайта находятся примеры из сборника программ "Архив файлов на Microsoft Access". В нем рассказывается о программировании форм, отчетов, таблиц и других объектов. Используйте этот архив для изучения работы с приложением Microsoft Office Access и программированием на Visual Basic for Application. Тем кто уже знаком с VBA, используйте поиск для нахождения кодов. Наберите, например, DAO, ADO, Recordset и найдете нужную ссылку для решения проблемы с программированием

Microsoft Access. Как вызвать диалог открытия (закрытия) файлов

09 сентября 2022 Admin (0)

08. Это типовой диалог Windows, который позволяет выбрать файл. Есть диалог и Microsoft Office с аналогичными целями. Его смотрите в других примерах (14 Файлы).

'Структура файла, описание дано ниже
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

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

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

'Флажки для параметра 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

Dim OFNAME As OPENFILENAME 'Назначаем переменную для файла

'==============================================================
'   Назначение
'        Открытие окна диалога файлов
'   Параметры:
'        strFilter - строка фильтра
'        strIniFile - файл инициализации
'        strTitleDlg - заголовок окна
'        strDefExt - расширение по умолчанию
'        strCurDir - текущая папка
'
Public Function funGetOpenFileName( _
    hWnd As Long, _
    strFilter As String, _
    strIniFile As String, _
    strTitleDlg As String, _
    strDefExt As String, _
    strCurDir As String) As String
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 'Собственный диалог
         '*** Старт
         'If GetOpenFileName(OFNAME) = True Then  'Win 98 Попробуйте такой вариант
         Flag = GetOpenFileName(OFNAME) 'Общий случай
         If Flag Then  'Открываем диалог и находим имя файла
              funGetOpenFileName = Left(.lpstrFile, InStr(.lpstrFile, Chr(0)) - 1)
         Else
              funGetOpenFileName = ""
         End If
    End With
End Function

'==============================================================
'   Назначение
'        Открытие окна диалога файлов
'   Параметры:
'        strFilter - строка фильтра
'        strIniFile - файл инициализации
'        strTitleDlg - заголовок окна
'        strDefExt - расширение по умолчанию
'        strCurDir - текущая папка
'
Public Function funGetSaveFileName( _
    hWnd As Long, _
    strFilter As String, _
    strIniFile As String, _
    strTitleDlg As String, _
    strDefExt As String, _
    strCurDir As String) As String
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 'Собственный диалог
         '*** Старт
         'If GetOpenFileName(OFNAME) = True Then  'Win 98 Попробуйте такой вариант
         Flag = GetSaveFileName(OFNAME) 'Общий случай
         If Flag Then  'Открываем диалог и находим имя файла
              funGetSaveFileName = Left(.lpstrFile, InStr(.lpstrFile, Chr(0)) - 1)
         Else
              funGetSaveFileName = ""
         End If
    End With
End Function

Microsoft Access. Как определить процедуру нажатия клавиш

09 сентября 2022 Admin (0)

07. Это пример необходим для того, чтобы использовать клавиатуру в ваших разработках. Обратите внимание какой код передает кнопка на клавиатуре для разных языков.

Option Compare Database
Option Explicit

'==============================================================
'   Нажать клавишу клавиатуры
Public Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyF1 '0x70 F1 ключ
        Case vbKeyF2 '0x71 F2 ключ
        Case vbKeyF3 '0x72 F3 ключ
        Case vbKeyF4 '0x73 F4 ключ
        Case vbKeyF5 '0x74 F5 ключ
        Case vbKeyF6 '0x75 F6 ключ
        Case vbKeyF7 '0x76 F7 ключ
        Case vbKeyF8 '0x77 F8 ключ
        Case vbKeyF9 '0x78 F9 ключ
        Case vbKeyF10 '0x79 F10 ключ
        Case vbKeyLButton '0x1 Левая клавиша мыши
        Case vbKeyRButton '0x2 Правая клавиша мыши
        Case vbKeyCancel '0x3 CANCEL ключ
        Case vbKeyMButton '0x4 Средняя клавиша мыши
        Case vbKeyBack '0x8 BACKSPACE ключ
        Case vbKeyTab: '0x9 TAB ключ
        Case vbKeyClear '0xC CLEAR ключ
        Case vbKeyReturn '0xD ENTER ключ
        Case vbKeyShift '0x10 SHIFT ключ
        Case vbKeyControl '0x11 CTRL ключ
        Case vbKeyMenu '0x12 MENU ключ
        Case vbKeyPause '0x13 PAUSE ключ
        Case vbKeyCapital '0x14 CAPS LOCK ключ
        Case vbKeyEscape '0x1B ESC ключ
        Case vbKeySpace '0x20 SPACEBAR ключ
        Case vbKeyPageUp '0x21 PAGE UP ключ
        Case vbKeyPageDown '0x22 PAGE DOWN ключ
        Case vbKeyEnd '0x23 END ключ
        Case vbKeyHome '0x24 HOME ключ
        Case vbKeyLeft '0x25 LEFT ARROW ключ
        Case vbKeyUp '0x26 UP ARROW ключ
        Case vbKeyRight '0x27 RIGHT ARROW ключ
        Case vbKeyDown '0x28 DOWN ARROW ключ
        Case vbKeySelect '0x29 SELECT ключ
        Case vbKeyPrint '0x2A PRINT SCREEN ключ
        Case vbKeyExecute '0x2B EXECUTE ключ
        Case vbKeySnapshot '0x2C SNAPSHOT ключ
        Case vbKeyInsert '0x2D INSERT ключ
        Case vbKeyDelete '0x2E DELETE ключ
        Case vbKeyHelp '0x2F HELP ключ
        Case vbKeyNumlock '0x90 NUM LOCK ключ
        Case Else
            'MsgBox "Другой ключ"
    End Select
        Me.myKey.Caption = "Код кнопки клавиатуры: "  Format(KeyCode, "000")
        Me.myShift.Caption = "Код кнопки Shift: "  Format(Shift, "000")
        Me.myXY.Caption = "Координаты: -"
        
        'Обнулить данные, чтобы не работали клавиши
        'и другие "Alt-", "F1" и т.п.
        KeyCode = 0
        Shift = 0
End Sub

'==============================================================
'   Открытие модуля
Private Sub butVBA_Click()
    DoCmd.OpenModule Me.Module
End Sub

'==============================================================
'   Загрузка формы
Private Sub Form_Load()
    Me.KeyPreview = True 'Включить обработку клавиатуры
End Sub

'==============================================================
'   Нажатие клавиши мыши
Private Sub Пример_7_MouseDown(Button As Integer, Shift As Integer, X As Single, y As Single)
    Select Case Button
        Case acLeftButton
        Case acRightButton
        Case acMiddleButton
    End Select
    Select Case Shift
        Case acShiftMask
        Case acCtrlMask
        Case acAltMask
    End Select
    Me.myKey.Caption = "Кнопка мыши: "  Format(Button, "000")
    Me.myShift.Caption = "Код кнопки Shift: "  Format(Shift, "000")
    Me.myXY.Caption = "Координаты мыши в твипах: X="  X  ", Y="  y
    
End Sub

'==============================================================
'   Передвинуть мышь
Private Sub Пример_7_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
    Пример_7_MouseDown Button, Shift, X, y
End Sub

Microsoft Access. Как вставить в форму рисунок из каталога

09 сентября 2022 Admin (0)

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

Microsoft Access. Запуск команды Shell

09 сентября 2022 Admin (0)

Для быстрого запуска приложения из Access можно воспользоваться командой shell. Она позволяет запускать любые программы: notepad.exe, explorer.exe и т.п.

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, _
     ByVal lpOperation As String, _
     ByVal lpFile As String, _
     ByVal lpParameters As String, _
     ByVal lpDirectory As String, _
     ByVal nShowCmd As Long) _
As Long

Private Sub butOpenFolder_Click()
        Shell "explorer.exe ""C:\""", vbNormalFocus
End Sub

Private Sub butSelectFile_Click()
    ' Включите библитеку libDialogFiles
    Me.strFilePath = fOfficeGetFile("Выберите файл", "C:", "*.txt")
End Sub

Private Sub strFilePath_DblClick(Cancel As Integer)
On Error GoTo 999
'    If Me.Var = 1 Then
        Dim StartDoc As Long
        Dim SW_SHOWNORMAL As Long
        If Not IsNull(Me.strFilePath) Then
            StartDoc = ShellExecute(Me.hwnd, "", Me.strFilePath, _
                "", "", SW_SHOWNORMAL)
        End If
'    End If
    
    Exit Sub

999:
   MsgBox "Error: "  Err  " "  Error
   Exit Sub

End Sub

Microsoft Access. Диалог открытия файлов Microsoft Office

09 сентября 2022 Admin (0)

У 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

Microsoft Access. Автозагрузка файлов в таблицу

09 сентября 2022 Admin (0)

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

' При загрузке формы загружаем файлы
Private Sub Form_Load()
    funAutoReadAllFiles Application.CurrentProject.Path, "*.txt"
End Sub

' Прочитаем имена файлов и загрузим их в таблицу
Private Sub funAutoReadAllFiles(strDir As String, strFileExt As String)
Dim i As Long, rst As DAO.Recordset
On Error GoTo 999
        With Application.FileSearch
           .NewSearch
           .LookIn = strDir ' *.name
           .FILENAME = strFileExt ' *.txt
           .SearchSubFolders = False
           If .Execute(SortBy:=msoSortByFileName, _
                    SortOrder:=msoSortOrderAscending)  0 Then
                For i = 1 To .FoundFiles.Count
                    If MsgBox("Загрузить файл: "  .FoundFiles(i), vbInformation + vbOKCancel, "Загрузить") = vbOK Then
                        funAutoReadOneFile .FoundFiles(i), "Таблица5"
                        Me.table5.Requery
                    End If
                Next i
           End If
        End With
    Exit Sub      'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Загружаем файл в таблицу
Private Function funAutoReadOneFile(strFileName As String, strTable)
Dim fs, f, flag
Dim dbs As DAO.Database, rst As DAO.Recordset

    On Error GoTo 999
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(strFileName)
    
    ' Проверка файла
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("select * from "  strTable)
    
    If rst.RecordCount Then
        rst.MoveLast
        rst.MoveFirst
    End If
    
    rst.FindFirst "[FileName] = '"  strFileName  "'"
    If rst.NoMatch = False Then
        dbs.Close
        rst.Close
        Exit Function
    End If
    
    ' Добавление информации о дате создания
    rst.AddNew
    rst!FILENAME = strFileName
    rst!DateCreated = f.DateCreated
    
    ' Добавление информации о содержимом
    rst!Memo = ""
    Set f = fs.OpenTextFile(strFileName, 1, False)
    Do While f.AtEndOfStream  True
        rst!Memo = rst!Memo  f.ReadLine ' Читаем построчно
    Loop
    f.Close
    
    ' Сохранение содержимого
    rst.Update
    rst.Close
    dbs.Close
    
    Exit Function
999:
'Ошибка:
    MsgBox Err.Description
    Err.Clear
    rst.Close
End Function

Microsoft Access. Открытие бинарного файла.

09 сентября 2022 Admin (0)

Этот пример покажет Вам как управлять бинарными файлами из Access, метод нужен для обращения к файлам отличным от Access

'==============================================================
' Создаем бинарный файл
Private Sub butWrite_Click()
Dim intFile As Integer
Dim myRec As AppRecord
    
    
'    Open Me.strPath For Binary Access Write As #intFile
'    Open Me.strPath For Random As #intFile Len = Len(myRec)
    intFile = FreeFile()
    Open Me.strPath For Binary As #intFile
    With myRec ' Создание записи
        .ID = 125
        .Name1 = "Мой телефон"
        .Phone1 = 92345678
        .Date1 = Date
    End With
    Put #intFile, 1, myRec ' Сохранение в файле
    ' Закрываем файл
    Close #intFile
    ' Отображение кнопки
    Form_Load
    ' Сообщение
    MsgBox "Бинарный файл "  Me.strPath  " создан!", vbExclamation, "www.leadersoft.ru"
End Sub

Microsoft Access. Управление папками

09 сентября 2022 Admin (0)

если Вам необходимо из Microsoft Access управлять файлами, то этот набор функций раскажет как это сделать. Вы сможете удалять, создавать и копировать папки.

' Создание пустой папки
'   fs.CreateFolder "c:\a"
'
Private Sub butCreateFolder_Click()
On Error GoTo 999
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject") 'Создаем файловую систему
    'Создаем папку
    fs.CreateFolder Me.myFolder
    Set fs = Nothing
    MsgBox "Папка: "  Me.myFolder  " создана!", vbInformation, "Создание папки"
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Копирование папки c ее содержимым
'   fs.CopyFolder "c:\a", "c:\a1"
'
Private Sub butCopyFolder_Click()
On Error GoTo 999
    Dim fs, strNewFolder As String, flagExecute As Long
    Set fs = CreateObject("Scripting.FileSystemObject") 'Создаем файловую систему
    
    strNewFolder = Me.myFolder  "1" ' Новое имя
    flagExecute = MsgBox("Копировать папку: "  vbNewLine  _
        Me.myFolder  vbNewLine  "в:"  _
        strNewFolder, vbExclamation + vbOKCancel, "Копирование папки")
        
    If flagExecute = vbOK Then _
        fs.CopyFolder Me.myFolder, strNewFolder ' Копирование папки
    
    Set fs = Nothing
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Удаление папки c содержимым
'   fs.DeleteFolder "c:\a"
'
Private Sub butDeleteFolder_Click()
On Error GoTo 999
    If MsgBox("Удалить папку: "  Me.myFolder, vbExclamation + vbOKCancel, "Удаление папки") = vbOK Then
        Dim fs
        Set fs = CreateObject("Scripting.FileSystemObject") 'Создаем файловую систему
        'Удаляем папку
        fs.DeleteFolder Me.myFolder
        Set fs = Nothing
    End If
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Перемещение папки c содержимым
'   fs.MoveFolder "c:\a", "c:\a1"
'
Private Sub butMoveFolder_Click()
On Error GoTo 999
    Dim fs, strNewFolder As String, flagExecute As Long
    Set fs = CreateObject("Scripting.FileSystemObject") 'Создаем файловую систему
    
    strNewFolder = Me.myFolder  "1" ' Новое имя
    flagExecute = MsgBox("Переместить папку: "  vbNewLine  _
        Me.myFolder  vbNewLine  "в:"  _
        strNewFolder, vbExclamation + vbOKCancel, "Перемещение папки")
        
    If flagExecute = vbOK Then _
        fs.MoveFolder Me.myFolder, strNewFolder ' Перемещение папки
    
    Set fs = Nothing
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

Microsoft Access. Развернуть таблицу на все окно

09 сентября 2022 Admin (0)

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

Private Sub butExecute_Click()
    On Error GoTo 999
    funOffBars 'Гасим все панели
    DoCmd.ShowToolbar "Menu Bar", acToolbarYes 'Строка меню
    DoCmd.ShowToolbar "Table Datasheet", acToolbarYes 'Меню таблиц
    DoCmd.OpenTable "Пример 01", acViewNormal 'Открываем таблицу
    DoCmd.Maximize 'Масштабирование
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "Масштабирование"
    Err.Clear
End Sub

Microsoft Access. Свойства папки и ее объектов

09 сентября 2022 Admin (0)

Этот пример покажет Вам как правильно определить различные свойства папок в 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