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

01. ADO и DAO - два разных метода доступа к данным реализованы в этом примере. Используйте этот пример для создания новых баз данных из Access. ADOX - это библиотека расширенных функций базы данных.

'==============================================================
' ADOX. Создание базы данных
Private Sub butADO_Click()
Dim cat As New ADOX.Catalog, strmdb As String
    
    ' Определение файла
    strmdb = Application.CurrentProject.Path  "\temp.mdb" ' Путь базы
    If Dir(strmdb)  "" Then Kill strmdb 'Уничтожаем старую базу данных
    
    ' ADOX. Создание базы
    cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="  strmdb
    Set cat = Nothing
    MsgBox "База создана (ADOX)!", vbExclamation, "Лидер Access"
   
   ' Удаление базы
   If Dir(strmdb)  "" Then Kill strmdb 'Уничтожаем старую базу данных
End Sub

'==============================================================
' DAO. Открытие базы данных
Private Sub butDAO_Click()
Dim dbs As DAO.Database, strmdb As String
   
   ' Определение файла
   strmdb = Application.CurrentProject.Path  "\temp.mdb" ' Путь базы
   If Dir(strmdb)  "" Then Kill strmdb 'Уничтожаем старую базу данных
   
   ' DAO. Открываем на чтение
   DBEngine.CreateDatabase strmdb, dbLangCyrillic
   MsgBox "База создана (DAO)!", vbExclamation, "Лидер Access"
   
   ' Удаление базы
   If Dir(strmdb)  "" Then Kill strmdb 'Уничтожаем старую базу данных
End Sub

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

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

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

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

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

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

04. Данный пример показывает как можно создать таблицу в Microsoft Word, используя vba в Word. При этом создается соединение внутри документа Word. Обратите внимание, что функция InsertDatabase отличается параметрами в разных версиях офиса.

Option Compare Database
Option Explicit
'#Const AccessVer = 2000
'#Const AccessVer = 2002
#Const AccessVer = 2003

'***************************************************************
'04.Пример. Как создать таблицу в документе Word ?
'***************************************************************

'==============================================================
'   Создание таблицы в документе Word
'   ---------------------------------
'   Для этого Вы должны создать в шаблоне la_automat.dot
'   закладку с имеенем Таблица. Например,
'   Вставка - Закладка ... - Имя закладки=Таблица
'   (Нажмите кнопку Добавить и сохраните шаблон)
'
Private Sub butNewWord_Click()
Dim app As Word.Application  'Приложение программы
Dim strDOC As String ' Имя документа
Dim strDOT As String ' Имя шаблона
Dim strMDB As String ' Имя базы данных
Dim rng As Word.Range ' Область данных
Dim tbl As Word.Table ' Таблица документа
Dim c As Word.Cell ' Ячейка таблицы
Dim i As Long ' Переменная

    On Error GoTo 999
    ' Определяем имена шаблона, документа и базы данных
    With Application.CurrentProject
        strDOT = .Path  "\"  "la_automat.dot"
        strDOC = .Path  "\"  "la_automat.doc"
        strMDB = .Path  "\"  .Name
    End With
    
    ' Управление документом Word
    Set app = New Word.Application 'Новое приложение Word
    app.Visible = True 'Отображаем документ
    app.Documents.Add strDOT 'Добавляем шаблон
    
    ' Выбираем закладку (позицию) таблицы
    Set rng = app.ActiveDocument.Bookmarks("Таблица").Range
    With rng
        .Collapse wdCollapseEnd
        ' Вставляем таблицу, используя запрос из базы данных
        #If AccessVer = 2000 Then
            .InsertDatabase _
                Style:=191, _
                LinkToSource:=False, _
                Connection:="Query ЗапросПримера04", _
                DataSource:=strMDB
        #ElseIf AccessVer = 2002 Then
            .InsertDatabase Format:=0, Style:=0, LinkToSource:=False, _
            Connection:= _
            "Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source="  strMDB  ";Mode=Read;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engi" _
            , SQLStatement:="SELECT * FROM `ЗапросПримера04`"  "", PasswordDocument _
            :="", PasswordTemplate:="", WritePasswordDocument:="", _
            WritePasswordTemplate:="", DataSource:= _
            strMDB, From:=-1, To:=-1, _
            IncludeFields:=True
        #Else
            .InsertDatabase Format:=0, Style:=0, LinkToSource:=False, _
                Connection:= _
                "Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source="  strMDB  ";Mode=Read;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLE" _
                , SQLStatement:="SELECT * FROM `ЗапросПримера04`"  "", PasswordDocument _
                :="", PasswordTemplate:="", WritePasswordDocument:="", _
                WritePasswordTemplate:="", DataSource:= _
                strMDB, From:=-1, To _
                :=-1, IncludeFields:=True
        #End If
        
        i = .Tables.Count ' Всего таблиц в данной области
        Set tbl = .Tables(i) ' Созданная таблица
        ' Форматируем всю таблицу
        tbl.Range.Font.Size = 10 ' Выбираем шрифт
        tbl.AutoFormat wdTableFormatGrid8 ' Выбираем авто-формат
       
        ' Вставляем колонку в начало таблицы
        tbl.Columns.Add tbl.Columns(1) ' Добавляем колонку
        i = 0
        For Each c In tbl.Range.Columns(1).Cells
            If i Then
                ' Изменяем данные
                c.Range.InsertAfter Format(i, "000") ' Вставить данные
                c.Range.ParagraphFormat.Alignment = wdAlignParagraphRight  'Правый формат
            Else
                ' Изменяем заголовок ячейки
                tbl.Range.Columns(1).Cells(1).Range.Text = "Пункт"
            End If
            i = i + 1
        Next c
        ' Форматируем заголовок, т.е. всю строку
        tbl.Rows(1).Select ' Выбираем заголовок
        With app.Selection
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Font.Name = "Arial" ' Имя шрифта
            .Font.Size = 10 ' Размер шрифта
        End With
        
        ' Добавляем новую строку
        tbl.Rows.Add ' Добавляем строку в конец таблицы
        With tbl.Cell(tbl.Rows.Count, 1) ' Выбираем 1 ячейку строки
          .Formula "=SUM(ABOVE)" ' Устанавливаем формулу
          .Shading.BackgroundPatternColorIndex = wdDarkRed ' Назначаем цвет фона
          .Range.Font.Bold = True ' Толщина (вес) текста
        End With
   End With
    
    app.ActiveDocument.SaveAs strDOC  ' Сохраняем файл
    ' app.Quit 'Закрываем приложение
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
    app.Quit
End Sub