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

Использование Application.FileSearch поможет Вам найти файлы на диске. Для Office 2007 эта функция не работает. Можно использовать другие функции, типа Dir, FileSystemObject и т.п.

' Поиск файлов по шаблону
Private Sub butRead_Click()
Dim i As Long
On Error GoTo 999
    With Application.FileSearch
       .NewSearch
       .LookIn = Me.myFolder ' = c:\
       .FILENAME = Me.myExt ' = *.mdb
       .SearchSubFolders = Me.myFflagSubFolder ' = True
       If .Execute(SortBy:=msoSortByFileName, _
                SortOrder:=msoSortOrderAscending)  0 Then
            Me.progress = "Count="  .FoundFiles.Count  vbCrLf
            For i = 1 To .FoundFiles.Count
                Me.progress = Me.progress  .FoundFiles(i)  vbCrLf
            Next i
       End If
    End With
    Exit Sub      'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

01. Dictionary - этот объект можно использовать для создания массивов, даже для форм. Таким образом можно создать интерфейс, который будет открывать 2 одинаковые формы, что в Access нереально создать обычным способом.

'==============================================================
'   Использование массива Dictionary для таблицы
Public Function funArrayDictionary() As String
Dim s As String, i  As Integer, dbs As Database, rst As Recordset
Dim myArray, myBooks 'Переменные для массива
   
    On Error GoTo 999 'Обработка ошибки

'1.Открытие таблицы
    Set dbs = CurrentDb 'Выбираем базу данных
    Set rst = dbs.OpenRecordset("SELECT * FROM [Мои книги]") 'Создаем запрос
    If (rst.RecordCount = 0) Then 'Проверяем таблицу
        rst.Close 'Закрываем запрос
        MsgBox "Нет данных" 'Сообщаем об этом
        Exit Function
    End If

'2. Заполнение запроса
    rst.MoveLast
    rst.MoveFirst
    
'3. Заполнение массива
    Set myArray = CreateObject("Scripting.Dictionary") 'Создаем массив
    myArray.RemoveAll 'Удаляем все
    For i = 0 To rst.RecordCount - 1
          myArray.Add CStr(rst!Ключ), CStr(rst!Книга) 'Добавляем значение в массив
          rst.MoveNext 'переходим на следующую запись
    Next i

'4. Проверка массива
    myBooks = myArray.Items        'Выбираем все книги
    For i = 0 To myArray.Count - 1 'Создаем цикл
        s = s  myBooks(i)  vbCrLf  'Создаем список книг
    Next
    funArrayDictionary = s 'Возвращаем список

'5. Конец примера
    myArray.RemoveAll 'Удаляем массив
    rst.Close
    Set dbs = Nothing '!Внимание. Посылаем ... переменную!
    Exit Function
999:
    MsgBox Err.Description
    Err.Clear
    rst.Close
End Function

01. Сторнирование - это возврат денежных средств, отображается красным цветом. Смотрите как это можно сделать из VBA?

With [Form_Пример 01 пдч].Сумма
       .Format = "0.00;0.00[Red]" 'Красный цвет в поле
    End With

01. Это простейший пример для рабо��ы с шрихкодом. Как его создать, используя функции рисования, в Access или ASP.NET используйте специальные комменческие программы на этом сайте.

01. В этот примере вы видите, как можно использовать оператор GoTo для сообщения об ошибке. Она записывается в переменную Err.

Private Sub butRead_Click()
On Error GoTo 999 ' В случае возникновения ошибки перейти на метку 999
Dim a As Long
    a = Eval(Me.myEval)
    MsgBox "Результат: "  a, vbInformation, "Результат вычисления"
    Exit Sub 'Выходим из программы
999:
    MsgBox "Номер ошибки: "  Err.Number  vbNewLine  "Описание ошибки: "  Err.Description, vbCritical, "Ошибка в программе"
    Err.Clear 'Очищаем поток от ошибок
End Sub

01. Данный пример показывает Вам техническое решение, которое может использоваться для бинарного редактирования файлов Access. Цель решения сравниванить по битно 2 файла: зашифрованный и нет. Таким образом, Вы сможете найти область изменения файла, где хранится ее пароль. Данное утверждение верно, только для некоторых версий Access.

Option Compare Database
Option Explicit

'***************************************************************
'Пример 1:   Удаление/установка пароля базы Данных /04.09.2000/
'***************************************************************

Dim pwdFree, pwdOne 'Массивы переменных, сохраняющих пароли

'==============================================================
'Название
'   Пример 1. Инициализация данных
Private Sub Form_Open(Cancel As Integer)
    'Нет пароля, пример шестнадцатиричной записи
    pwdFree = Array(H86, HFB, HEC, H37, H5D, H44, _
                    H9C, HFA, HC6, H5E, H28, HE6, H13)
    'Пароль 1, пример десятичной записи
    pwdOne = Array(183, 251, 236, 55, 93, 68, _
                   156, 250, 198, 94, 40, 230, 19)
    
    'Значение файла в форме, назначаемое по умолчанию
    Me.myAccessFile.DefaultValue = "'"  funGetAppFolder  "\la_prot97.mdb"  "'"
    
    'Максимализировать приложение
    Application.DoCmd.RunCommand acCmdAppMaximize
End Sub

'==============================================================
'Название
'   Пример 1. Показать пароль
Private Sub butPassword_Click()
Dim s As String
    MsgBox "Файл: "  Me.myAccessFile  Chr(13)  funReadHead(Me.myAccessFile), vbInformation, "Пароль файла"
End Sub

'==============================================================
'Название
'   Пример 1. Удалить пароль
Private Sub butDelPassword_Click()
    funSetPassword 0, "Пароль удален!"
End Sub

'==============================================================
'Название
'   Пример 1. Установить пароль
Private Sub butSetPassword_Click()
    funSetPassword 1, "Установлен пароль: 1"
End Sub

'==============================================================
'Название
'   Пример 1. Прочитать заголовок пароля
Private Function funReadHead(myFile As String) As String
Dim i As Integer, ID As Byte, pwd(12) As Byte
    On Error GoTo 999
    'Часть заголовка не защищенного файла
        ID = FreeFile 'Получить свободный идентификатор файла
        Open myFile For Binary As ID 'Открываем файл
        funReadHead = ""
        For i = 0 To 12
            Get #ID, 67 + i, pwd(i) 'Читаем пароль
            funReadHead = funReadHead  Format(pwd(i), "000")  ","
        Next i
        Close 'Закрываем открытые файлы
    Exit Function
999:
    MsgBox Err.Description
End Function

'==============================================================
'Название
'   Пример 1. Изменить пароль
Private Sub funSetPassword(myFlag As Integer, myMsg As String)
Dim i As Integer, ID As Byte
    On Error GoTo 999
 
    If MsgBox("Изменить пароль файла ?", vbOKCancel + vbExclamation, "Изменение пароля") = vbOK Then
        ID = FreeFile 'Получить свободный идентификатор файла
        Open Me.myAccessFile For Binary As ID 'Открываем файл в двоичном виде
        For i = 0 To 12
            Select Case myFlag 'Выбираем режим установки
            Case 0: Put #ID, 67 + i, CByte(pwdFree(i)) 'Удаляем пароль
            Case 1: Put #ID, 67 + i, CByte(pwdOne(i))  'Записываем пароль 1
            End Select
        Next i
        Close 'Закрываем открытый файл
        MsgBox myMsg, vbInformation, "Изменение пароля" 'Сообщение
    End If
    
    Exit Sub
999:
    MsgBox Err.Description
End Sub

'==============================================================
'Название
'   Пример 1. проверить существование файла
Private Sub myAccessFile_AfterUpdate()
    If Dir(Me.myAccessFile) = "" Then
        MsgBox "Файл: "  Me.myAccessFile  " не существует!"
    End If
End Sub

'==============================================================
'Название
'   Пример 1. Открыть базу данных
Private Sub butView_Click()
      Application.FollowHyperlink Me.myAccessFile, , True
End Sub

'==============================================================
'Название
'   Пример 1. Прочитать папку (см. Лекции Access 2000)
Public Function funGetAppFolder() As String
Dim fs
    On Error GoTo 999  'Назначаем переход по ошибке
    Set fs = CreateObject("Scripting.FileSystemObject") 'Создаем файловую систему
    funGetAppFolder = fs.GetFile(CurrentDb.Name).ParentFolder 'Находим папку
    Set fs = Nothing 'Уничтожаем переменную
    Exit Function 'Выходим из программы
999:
    MsgBox Err.Description 'Сообщаем об ошибке
    Err.Clear 'Очищаем поток от ошибок
End Function

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

Private Sub butProgram1_Click()
    Me.MenuBar = "Мое меню"
    If Me.butProgram1.Caption = "Отобразить меню" Then
        DoCmd.ShowToolbar Me.MenuBar, acToolbarYes
        Me.butProgram1.Caption = "Погасить меню"
    Else
        DoCmd.ShowToolbar Me.MenuBar, acToolbarNo
        Me.butProgram1.Caption = "Отобразить меню"
    End If
End Sub

Данный пример показывает как можно создать календарь, используя ActiveX Calendar от Microsoft. Поставьте ссылку на C:\Program Files\Microsoft Office\OFFICE11\MSCALL.OCX. Применяется класс для создания календаря.

Option Compare Database
Option Explicit

Public WithEvents CurrentCal As MicrosoftCal

'   Настройка календаря
Private Sub Form_Load()
    Set CurrentCal = New MicrosoftCal
    Set CurrentCal.Cal = Me.myCal.Object
    With Me.CurrentCal.Cal ' Настройка календаря
        '.Value = Date ' Установка текущей даты
        .TitleFontColor = 255 ' Цвет заголовка
        .Year = Year(Date) ' Устанавливаем год
        .Month = Month(Date) ' Устанавливаем месяц
        .Day = Day(Date) ' Уставливаем день
        .NextDay ' Следующий день
        '.ShowTitle = False ' Гасим заголовок
        ' Введите точку и установите параметр
    End With
End Sub

'   Добавим событие-сообщение для нового класса
Public Sub CurrentCal_Progress(myMsg As String)
    If Me.butEvents Then
        Me.myEvents = myMsg  vbNewLine  Me.myEvents
        DoEvents
    End If
End Sub

'   Установлена дата
Public Sub myCal_AfterUpdate()
    'CurrentCal_Progress "Date: "  Me.myCal
End Sub

'   События для формы
Private Sub myCal_GotFocus()
    CurrentCal_Progress "GotFocus"
End Sub
Private Sub myCal_LostFocus()
    CurrentCal_Progress "LostFocus"
End Sub
Private Sub butEvents_AfterUpdate()
    Me.myEvents = ""
End Sub

'==============================================================

' Объявляем класс Calendar
Public WithEvents Cal As Calendar

' Объявляем событие для сообщений
Public Event progress(strMsg As String)

'==============================================================
'  События при создании/уничтожении класса
Private Sub Class_Initialize()
   ' Инициализация
End Sub
Private Sub Class_Terminate()
   ' Сохраняем данные
End Sub

'==============================================================
'  События до/после редактирования метки узла
Private Sub Cal_AfterUpdate()
   funPrintEvent "AfterUpdate: "  Me.Cal.Value
End Sub
Private Sub Cal_BeforeUpdate(Cancel As Integer)
   funPrintEvent "BeforeUpdate: "  Me.Cal.Value
End Sub
Private Sub Cal_NewMonth()
   funPrintEvent "NewMonth: "  Me.Cal.Value
End Sub
Private Sub Cal_NewYear()
   funPrintEvent "NewYear: "  Me.Cal.Value
End Sub

'==============================================================
'  События мышки
Private Sub Cal_Click()
   funPrintEvent "Click"
End Sub
Private Sub Cal_DblClick()
   funPrintEvent "DblClick"
End Sub

'==============================================================
'  События клавиатуры
Private Sub Cal_KeyDown(KeyCode As Integer, ByVal Shift As Integer)
   funPrintEvent "KeyDown (KeyCode: "  KeyCode  ", Shift = "  Shift  ")"
End Sub
Private Sub Cal_KeyPress(KeyAscii As Integer)
   funPrintEvent "KeyPress: "  KeyAscii
End Sub
Private Sub Cal_KeyUp(KeyCode As Integer, ByVal Shift As Integer)
    funPrintEvent "KeyUp (KeyCode: "  KeyCode  ", Shift = "  Shift  ")"
End Sub

'==============================================================
'   Функция сообщающая о получении событий
Private Function funPrintEvent(myMsg As String)
    RaiseEvent progress(myMsg) ' Генерируем событие для узла
End Function

Возможно Вам придется из программы регистрировать некоторые ActiveX Элементы. Этот пример показывает, как можно создать регистрацию элемента из Access, а также как можно ее удалить.

'  Проверка ссылок в таблице (дополнительная функция)
'
Private Sub Form_Open(Cancel As Integer)
Dim ref As Reference, i As Long
Dim dbs As DAO.Database, rst As DAO.Recordset
Dim strName As String
    
    On Error Resume Next
    ' Определяем свою папку OCX для ActiveX
    Me.myFolder = Application.CurrentProject.Path  "\ocx"
    
    ' Инициализируем таблицу
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("SELECT * FROM [Example 01] WHERE [myRef]=True")
    
    ' Просматриваем все ссылки
    rst.MoveLast
    rst.MoveFirst
    For i = 0 To rst.RecordCount - 1
        strName = rst!Name
        Set ref = Application.References(strName)
        rst.Edit
        If ref Is Nothing Then
            Err.Clear
            rst!Path = "Файл не найден!"
        Else
            rst.Edit
            rst!Path = CStr(ref.FullPath)
            rst!Ver = CStr(ref.Major)  "."  CStr(ref.Minor)
            Set ref = Nothing
        End If
        rst.Update
        rst.MoveNext
   Next
    rst.Close
    Set dbs = Nothing
    
    ' Обновляем таблицу
    Me.[01 RegActiveX_sub].Requery
    Exit Sub
999:
    MsgBox Err  ": "  Err.Description
    Err.Clear
    Resume Next
End Sub

'  Регистрация элементов
Private Sub butReg32_Click()
Dim ref As Reference, i As Long, strName As String
Dim dbs As Database, rst As Recordset
Dim strOcx As String

    On Error GoTo 999
    Set dbs = CurrentDb
    
    ' Определяем свою папку OCX для ActiveX
    Me.myFolder = Application.CurrentProject.Path  "\OCX"
    
    ' Инициализируем таблицу
    Set rst = dbs.OpenRecordset("SELECT * FROM [Example 01] WHERE [Path]='Файл не найден!'")
    On Error Resume Next
    
    ' Изменяем ссылки
    rst.MoveLast
    rst.MoveFirst
    For i = 0 To rst.RecordCount - 1
        strOcx = Me.myFolder  "\"  rst!File
        If Dir(strOcx)  "" Then ' Файл существует
            funRegsvr32 strOcx, "" ' Регистрируем ActiveX
            rst.Edit
            rst!Path = strOcx
            rst.Update
        Else
            MsgBox "Файл "  strOcx  " не найден!"
        End If
        rst.MoveNext
    Next
    Set dbs = Nothing
    Me.[01 RegActiveX_sub].Requery
    Exit Sub
999:
    MsgBox Err  ": "  Err.Description
    Err.Clear
End Sub

'   Регистрация ActiveX элемента в OC
'       regsvr32.exe  a.ocx   ' регистрация ActiveX
'       regsvr32.exe -u a.ocx ' отмена регистрации
'   Параметры
'       strFlag = "" или "-u"
'
Public Sub funRegsvr32(strOcx As String, strFlag As String)
Dim fs, strExe As String, strSysFolder
    On Error GoTo 999
    
    Set fs = CreateObject("Scripting.FileSystemObject") 'Создаем файловую систему
    
    ' Определяем системную папку
    strSysFolder = fs.GetSpecialFolder(1)
    strExe = strSysFolder  "\regsvr32.exe"  ' Составляем exe файл
    If Dir(strExe)  "" Then ' Проверяем exe-файл
       If Dir(strOcx)  "" Then
            ' Копируем в системную папку (не так важно)
            'fs.CopyFile strOcx, strSysFolder  "\"
            'strOcx = strSysFolder  "\"  fs.GetFileName(strOcx) ' Системный файл
            
            ' 1 способ
            If strFlag  "-u" Then
                References.AddFromFile strOcx
            Else
                ' Удаление регистрации
                'Dim ref As Reference
                'Set ref = References(strOcx)
                'References.Remove ref
            End If
            
            ' 2 способ. Регистрация/Удаление
            'strExe = strExe  " "  strFlag  " """  strOcx  """"
            'Shell strExe, vbHide 'Запускаем программу
       Else
            MsgBox "Нет файла: "  strOcx
       End If
    Else
       MsgBox "Нет файла: "  strExe
    End If
    Set fs = Nothing
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

05. Данный пример показывает, как можно создать папки в Outlook. В качестве примера загрузки берется Outlook Express с файлами dbx

'==============================================================
'  Создание папок с использованием Outlook
Private Sub butExecute_Click()
Dim app As Outlook.Application  'Приложение программы
Dim i As Integer 'Счетчик
Dim myNamespace, myfolder As MAPIFolder, mynewfolder

    On Error GoTo 999
        Set app = New Outlook.Application
        Set myNamespace = app.GetNamespace("MAPI")
        Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
        With Application.FileSearch
           .NewSearch
           .LookIn = Me.myFolderInternetExpress  ' = c:\
           .FileName = "*.dbx" ' Выбираем файлы для Outlook Express
           .SearchSubFolders = True
           If .Execute(SortBy:=msoSortByFileName, _
                    SortOrder:=msoSortOrderAscending)  0 Then
                Me.Progress = "Count="  .FoundFiles.Count  vbCrLf
                Dim strFile As String
                For i = 1 To .FoundFiles.Count
                    strFile = fGetFileName(.FoundFiles(i))
                    Me.Progress = Me.Progress  strFile  vbCrLf
                    Set mynewfolder = myfolder.Folders.Add(strFile)
                    DoEvents
                Next i
           End If
        End With
        
        app.Quit 'Закрываем Outlook
        MsgBox "Папки созданы!", vbExclamation, "Почта"
     Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
    Resume Next
End Sub


Public Function fGetFileName(strPath As String) As String
Dim fs
    On Error GoTo 999
    Set fs = CreateObject("Scripting.FileSystemObject")
    fGetFileName = fs.GetBaseName(strPath)
    Set fs = Nothing
    
    Exit Function
999:
    MsgBox Err.Description, vbCritical, strPath
    Err.Clear
End Function