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

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

04. Для управления счетчиком в таблицах можно использовать эти функции

Private Sub butExecute_Click()
Dim idx As Index, fld As Field
        
        On Error Resume Next
        'Удаляем все лишнее
        tdf.Indexes.Delete "PrimaryKey" 'Удаляем индекс
        tdf.Indexes.Refresh 'Сохраняем изменение
        tdf.Fields.Delete "Код" 'Удаляем поле
        tdf.Fields.Refresh 'Изменяем таблицу
        Err.Clear 'Очищаем от ошибки, если нет поля
        
        On Error GoTo 999
       'Создаем поле "Счетчик" с новыми значениями
        Set fld = tdf.CreateField("Код") 'Создание
        fld.Type = dbLong 'Тип поля
        fld.Properties("Attributes") = dbAutoIncrField 'Назначение атрибутов счетчика
        tdf.Fields.Append fld 'Добавить поле
        tdf.Fields.Refresh 'Изменяем таблицу
        
        
        'Создаем индекс
        Set idx = tdf.CreateIndex("МойИндекс") 'Создаем индекс
        idx.Fields.Append idx.CreateField("Код") 'Добавляем поле в индекс
        idx.Name = "PrimaryKey" 'Изменение имени индекса
        idx.Primary = True      'Атрибут ключа
        tdf.Indexes.Append idx  'Добавить индекс
        tdf.Indexes.Refresh     'Сохраняем индекс
        
        'Сообщение
        MsgBox "Создан новый счетчик 'Код'!", vbInformation
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "Создание поля"
    Err.Clear
End Sub

'==============================================================
'   Удаляем поле и индекс
Private Sub butDelete_Click()
    On Error Resume Next
    tdf.Indexes.Delete "PrimaryKey" 'Удаляем индекс
    tdf.Indexes.Refresh 'Сохраняем изменение
    Err.Clear
    
    MsgBox "Индекс PrimaryKey удален!", vbInformation
End Sub

Форум DNN - хранит сообщения в базе данных Microsoft SQL Server. Этот пример показывает как можно использовать Access для автоматизированной загрузки сообщений в форум. Обратите внимание на dnn_Forum_PostAdd. Application.FileSearch - не работает в Office 2007, используйте другую функцию (Dir) для получения списка файлов

Option Compare Database

' Все объекты объявления в форуме
Public Type tpAdds
    User As String     ' Имя пользователя
    Email As String    ' Имя почты
    AddDate As Date    ' Дата записи
    Subject As String  ' Тело
    Body As String     ' Текст
    Section As String  ' Секция
End Type

Public adds() As tpAdds   ' Объявления на одну тему
Public tags(10) As String ' Список тегов
Public fso                ' Объект файловой системы
Public frmMain As Form    ' Форма для вывода данных

' Читаем все файлы html
Public Function funReadHtml(frm As Form, MaxAdds As Long) ' Максимальное число объявлений, 0 - все загружаем
    Dim fname As String, html, buf, i As Long
    Dim cnn As ADODB.Connection
    
    ' Инициализация тегов для html файла
    Set frmMain = frm
    
    ' Поиск имени
    tags(0) = "size=""2"""
    tags(1) = "br"
    
    ' Поиск Email
    tags(2) = "mailto:"
    tags(3) = """"
    
    ' Поиск даты и времени
    tags(4) = "alt=""Email""/abrbr"
    tags(5) = "br/font"
    
    ' Поиск темы
    tags(6) = "u"
    tags(7) = "/u"
    
    ' Поиск сообщения
    tags(8) = "Сообщение:br"
    tags(9) = "/font/td"

    ' Разбор файлов
    With Application.FileSearch
        .NewSearch
        .LookIn = CurrentProject.Path  "\Data"
        .SearchSubFolders = False
        .fileName = "*.htm"
        If .Execute()  0 Then
            Set cnn = New ADODB.Connection
            cnn.CursorLocation = adUseClient
            If CurrentProject.IsConnected = True Then
                cnn.Open CurrentProject.AccessConnection.ConnectionString
            End If
            If MaxAdds = 0 Then MaxAdds = .FoundFiles.Count
            funPrintStatus " --- Старт: "  Now
            For i = 1 To MaxAdds
                fname = .FoundFiles(i)
                funPrintStatus "Прочитан файл: "  fname  ": "  Now
                ' Читаем файл
                Call fsoReadAllFile(fname, html)
                ' Разбор файла
                If Len(html)  10 Then
                    funWriteHtml cnn, html, fGetFileName(fname)
                    fMoveFile fname, fname  "1"
                End If
            Next i
            funPrintStatus "--- Конец: "  Now
            If CurrentProject.IsConnected = True Then
                cnn.Close
            End If
        Else
            MsgBox "В каталоге: "  .LookIn  " файлы не найдены! Возможно они были переименованы", vbExclamation, "Администратор"
        End If
    End With
End Function

' Сохраняем информацию в массиве объявлений
Public Function funWriteHtml(cnn As ADODB.Connection, html, fileName As String)
Dim i As Long, n As Long, p1 As Long, p2 As Long, k As Long, buffer As String, Sec As String

    ' Поиск границы данных, далее идет форма
    'p2 = InStr(1, html, "!---"  fileName  "---")
    p2 = InStr(1, html, ".htm---")
    buf = Split(Left(html, p2), "tr")
    
    ' Число строк
    n = UBound(buf)
    ' Название секции
    p1 = InStr(1, buf(1), "b  /b")
    p1 = InStr(p1 + 10, buf(1), "b  ") + 6
    p2 = InStr(p1, buf(1), " /b")
    If p2  p1 Then Sec = Mid(buf(1), p1, p2 - p1)
    If InStr(1, Sec, "") Then Sec = ""
    
    If n  2 Then
        ReDim adds(n - 3) ' Пропускаем 3 строки сверху
        For i = 3 To n
            p1 = 1 ' Начало поиска
            adds(i - 3).Section = Sec
            For j = 0 To 4
                ' Начало поиска
                k = InStr(p1, buf(i), tags(j * 2))
                ' Левый тег найден
                If k  0 Then
                    p1 = k + Len(tags(j * 2))
                    p2 = InStr(p1, buf(i), tags(j * 2 + 1))
                    ' Результат поиска правого тега - положительный
                    If p2  p1 Then
                        buffer = Mid(buf(i), p1, p2 - p1)
                        Select Case j
                        Case 0: adds(i - 3).User = buffer
                        Case 1: adds(i - 3).Email = buffer
                        Case 2: adds(i - 3).AddDate = CDate(Replace(buffer, "br", " "))
                        Case 3: adds(i - 3).Subject = buffer
                        Case 4: adds(i - 3).Body = buffer
                        End Select
                        ' Новая позиция поиска
                        p1 = p2 + Len(tags(j * 2 + 1))
                    End If
                End If
            Next
        Next
        ' Добавляем данные в конференцию
        dnn_Forum_PostAdd cnn, fileName
    End If
End Function

' Получаем имя файла
Public Function fGetFileName(strPath As String) As String
Dim fs
    On Error GoTo 999
    Set fs = CreateObject("Scripting.FileSystemObject")
    fGetFileName = fs.GetFileName(strPath)
    Set fs = Nothing
    
    Exit Function
999:
    MsgBox Err.Description, vbCritical, strPath
    Err.Clear
End Function

Public Function fMoveFile(strPath1 As String, strPath2 As String) As Boolean
Dim fs
    On Error GoTo 999
    Set fs = CreateObject("Scripting.FileSystemObject")
    fs.MoveFile strPath1, strPath2
    Set fs = Nothing
    Exit Function
999:
    'MsgBox Err.Description, vbCritical, strPath
    Err.Clear
    fDeleteFile = False
End Function


' Загрузка всего файла в буфер
Public Function fsoReadAllFile(fname, buffer)
Dim f
    ' Создаем файловую систему
     fsoCreateFileSystem
     
    ' Читаем весь файл
    If (fso.FileExists(fname)) Then
        Set f = fso.OpenTextFile(fname, 1, -1)
        buffer = f.ReadAll
        f.Close
        fsoReadAllFile = True
    Else
        fsoReadAllFile = False
    End If
End Function


Public Function fsoCreateFileSystem()
    If IsEmpty(fso) Then
        Set fso = CreateObject("Scripting.FileSystemObject")
    End If
End Function

' Печать информации
Private Sub funPrintStatus(txt As String)
    On Error GoTo 999
    If frmMain.txtStatus.ListCount  500 Then
        frmMain.txtStatus.RowSource = ""
    End If
    
    frmMain.txtStatus.RowSource = txt  ";"  frmMain.txtStatus.RowSource
    DoEvents
    frmMain.Repaint
    Exit Sub
999:
    frmMain.txtStatus.RowSource = ""
End Sub

'
' Добавляем объявления в конференцию Dotnetnuke
' Работает только при подключении к серверу с процедурой: Forum_PostAdd
'
Private Function dnn_Forum_PostAdd(cnn As ADODB.Connection, fileName As String) As Boolean
' Вспомогательные параметры
Dim cmd As New ADODB.Command, i As Long, PostID As Long, cnt As Long
    On Error GoTo 999
    If CurrentProject.IsConnected = False Then
        MsgBox "Необходимо adp проект связать с базой данных dotnetnuke", vbCritical, "Admin"
        Exit Function
    End If
    PostID = 0
    Set cmd.ActiveConnection = cnn
    cmd.CommandText = "dnn_Forum_PostAdd" ' По умолчанию процедура добавления: Forum_PostAdd
    cmd.CommandType = adCmdStoredProc
    cmd.Parameters.Refresh ' Запрос параметров процедуры
    Dim rst As New ADODB.Recordset
    For i = 0 To UBound(adds)
         ' Инициализируем данные
        cmd.Parameters("@ParentPostID") = PostID
        cmd.Parameters("@ForumID") = 1  ' Access Forum
        cmd.Parameters("@UserID") = 19
        cmd.Parameters("@RemoteAddr") = ""
        cmd.Parameters("@Notify") = 0
        cmd.Parameters("@Subject") = adds(i).Subject
        cmd.Parameters("@Body") = adds(i).Body  "P.S. "  adds(i).Section  "brАвтор: a href=""mailto:"  adds(i).Email  """"  adds(i).User  "/a от "  adds(i).AddDate  " a href=""http://www.leadersoft.ru/rusboard/data/"  fileName  """Источник .../a"
        cmd.Parameters("@IsPinned") = 0
        cmd.Parameters("@PinnedDate") = adds(i).AddDate
        cmd.Parameters("@IsClosed") = 0
        cmd.Parameters("@Image") = ""
        cmd.Parameters("@mediaURL") = ""
        cmd.Parameters("@mediaNAV") = ""
        cmd.Parameters("@ObjectTypeCode") = 0
        cmd.Parameters("@ObjectID") = 0
        cmd.Parameters("@FileAttachmentURL") = ""
        cmd.Execute RecordsAffected:=cnt, options:=adExecuteNoRecords
        If cnt  0 And i = 0 Then
            PostID = DMax("PostID", "dnn_Forum_Posts") ' Запрос последнего добавленного сообщения
        End If
    Next
    Exit Function
999:
    MsgBox Err.Description, vbCritical, "Администратор"
End Function

' Закрыть текущее соединение
Public Function fCloseConnect()
    CurrentProject.OpenConnection "Provider="
End Function

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

Private Sub Form_Load()
Dim hRgn As Long    'Область окна
Dim x0 As Long, y0 As Long, ww As Long, hh As Long
Dim scrX As Long 'Коэффициент перевода в пикселы
Dim scrY As Long 'Коэффициент перевода в пикселы
Dim frmhwnd As Long, frmhdc As Long
    
    ' Очистить сообщения
    DoEvents
    
    ' Определяем размеры окна и область отсечения
    frmhwnd = apiFindWindowEx(Me.hWnd, apiFindWindowEx(Me.hWnd, 0, "OFormSub", ""), "OFormSub", "")
    If frmhwnd = 0 Then Exit Sub
    
    ' Определяем контекст устройства
    frmhdc = apiGetDC(frmhwnd)
    
    'Определяем размеры области отсечения
    'Число твипов в пикселах
    scrX = 1440 / apiGetDeviceCaps(frmhdc, LOGPIXELSX)
    scrY = 1440 / apiGetDeviceCaps(frmhdc, LOGPIXELSY)
    With Me.Controls("myPicture")
        x0 = .Left / scrX '+ 1 'Позиция в пикселах
        y0 = .Top / scrY '+ 1 'Позиция в пикселах
        ww = .Width / scrX - 1 'Ширина таймера
        hh = .Height / scrY - 1 'Высота таймера
    End With
    Call apiReleaseDC(frmhwnd, frmhdc)
    hRgn = apiCreateEllipticRgn(x0, y0, ww, hh) 'Область отсечения
    
    'Отрезаем лишнее от окна
    If hRgn  0 Then
       Call apiSetWindowRgn(Me.hWnd, hRgn, True)
    End If
    
End Sub

' leadersoft.ru - v01 от 02.03.2001
Private Sub Form_Open(Cancel As Integer)
    ' При открытии запускаем проигрыватель
    nFileName = Application.CurrentProject.Path  "\Flaming Star.mp3"
    If Dir(nFileName, vbNormal)  "" Then
        Me.butExit.SetFocus
        Me.butSelect.Enabled = False
        MP3Play Me.hWnd, nFileName
    End If
End Sub

' Определяем режим движения окна
' leadersoft.ru - v01 от 02.03.2001
Private Sub myPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    apiReleaseCapture 'Эмуляция захвата окна
    Call apiSendMessage(Me.hWnd, WM_SYSCOMMAND, SC_MOVE_MOUSE, 0)
End Sub

'Это просто остановка программы
Private Sub butVBA_Click()
    Stop
End Sub

'
' Сайт: http://www.vbforums.com/archive/index.php/t-272432.html
'
Public Function MP3Play(wndHandle As Long, sFileName As String)
Dim cmdToDo As String * 255
Dim dwReturn As Long
Dim ret As String * 128
Dim tmp As String * 255
Dim lenShort As Long
Dim ShortPathAndFie As String, glo_HWND As Long

    If Dir(sFileName) = "" Then
        mmOpen = "Error with input file"
        Exit Function
    End If
    lenShort = GetShortPathName(sFileName, tmp, 255)
    ShortPathAndFie = Left$(tmp, lenShort)
    glo_HWND = wndHandle
    cmdToDo = "open "  ShortPathAndFie  " type MPEGVideo Alias MP3Play"
    dwReturn = mciSendString(cmdToDo, 0, 0, 0)
    If dwReturn  0 Then 'not success
        mciGetErrorString dwReturn, ret, 128
        mmOpen = ret
        MsgBox ret, vbCritical
        Exit Function
    End If
    mmOpen = "Success"
    mciSendString "play MP3Play", 0, 0, 0
End Function

Public Function MP3Pause()
    mciSendString "pause MP3Play", 0, 0, 0
End Function

Public Function MP3UnPause()
    mciSendString "play MP3Play", 0, 0, 0
End Function

Public Function MP3Stop() As String
    mciSendString "stop MP3Play", 0, 0, 0
    mciSendString "close MP3Play", 0, 0, 0
End Function


Private Sub butExit_Click()
    DoCmd.Close acForm, Me.Form.Name
End Sub

Private Sub butSelect_Click()
    Me.butExit.SetFocus
    butSelect.Enabled = False
'    butExit.Enabled = False
    Open_file
End Sub

Private Sub butPause_Click()
    Me.butExit.SetFocus
    If butPause.Caption = "Пауза" Then
        butPause.Caption = "Играть "
        MP3Pause
    Else
        butPause.Caption = "Пауза"
        MP3UnPause
    End If
End Sub

Private Sub butStop_Click()
    Me.butExit.SetFocus
    butPause.Enabled = False
    butStop.Enabled = False
    butStart.Enabled = False
    butSelect.Enabled = True
    butPause.Caption = "Пауза"
    MP3Stop
End Sub

Private Sub butStart_Click()
    Me.butExit.SetFocus
    mciSendString "stop MP3Play", 0, 0, 0
    mciSendString "play MP3Play from 0", 0, 0, 0
    butPause.Caption = "Пауза"
End Sub

' Срабатывает, когда заканчивается музыка
Private Sub Form_Timer()
    If IsPlaying = False And butSelect.Enabled = False And butPause.Caption = "Пауза" Then
        butStop_Click
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    MP3Stop
End Sub

Private Sub Open_file()
Dim cderr As Long
    OFN.lStructSize = 76
    OFN.hwndOwner = Me.hWnd
    OFN.lpstrFilter = "mp3 (*.mp3)" + Chr(0) + "*.mp3" + Chr(0) + Chr(0)
    OFN.lpstrCustomFilter = String(256, Chr(0))
    OFN.nMaxCustFilter = 256
    OFN.lpstrFile = "" + String(512, Chr(0))
    OFN.nMaxFile = 512
    OFN.lpstrFileTitle = String(256, Chr(0))
    OFN.nMaxFileTitle = 256
    OFN.flags = OFN_FILEMUSTEXIST + OFN_HIDEREADONLY
    '************
    DoEvents
    '************
    If GetOpenFileName(OFN) Then
        OFN.lpstrFile = Mid(OFN.lpstrFile, 1, InStr(OFN.lpstrFile, Chr(0)) - 1)
        nFileName = OFN.lpstrFile
        OFN.lpstrFileTitle = Mid(OFN.lpstrFileTitle, 1, InStr(OFN.lpstrFileTitle, Chr(0)) - 1)
        InitialDir = Left(OFN.lpstrFile, Len(OFN.lpstrFile) - Len(OFN.lpstrFileTitle))
    Else
        cderr = CommDlgExtendedError
        GoTo ex
    End If
    MP3Play hWnd, nFileName
    butPause.Enabled = True
    butStop.Enabled = True
    butStart.Enabled = True
    butExit.Enabled = True
    Exit Sub
ex:
    butSelect.Enabled = True
    butExit.Enabled = True
End Sub

' Проверка игры
Public Function IsPlaying() As Boolean
    Static s As String * 30
    mciSendString "status MP3Play mode", s, Len(s), 0
    IsPlaying = (Mid$(s, 1, 7) = "playing")
End Function

03. С помощью функции GetRow можно организовать поиск в таблицы без применения DAO или ADO. Если таблица небольшая считываем данные в массив и поиск организуем уже в нем. Все работает быстро, т.к. не надо обращаться к функциям чтения записей.

Option Compare Database
Option Explicit
Dim myTable As Variant 'Массив данных из таблицы

'==============================================================
'   Заполнение массива
'   myTable(x,y)
'       х - это поля
'       y - это строки
Private Sub Form_Open(Cancel As Integer)
        myTable = funGetRows 'Заполняем массив
        myColumn_AfterUpdate 'Отображаем данные
End Sub

'==============================================================
'   Обновление строки
Private Sub myRow_AfterUpdate()
    Me.myColumnRow.Caption = "Данные в ячейке ("  _
        Me.myColumn  ","  _
        Me.myRow  "): "  _
        myTable(Me.myColumn, Me.myRow)
End Sub

'==============================================================
'   Обновление поля
Private Sub myColumn_AfterUpdate()
    myRow_AfterUpdate
End Sub

'   Заполнение массива
Public Function funGetRows() As Variant
Dim dbs As Database, rst As Recordset, i As Integer

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("SELECT * FROM [Мои книги] ORDER BY [Книга]")
    If rst.RecordCount  0 Then
        With rst
            .MoveLast 'Заполняем запрос
            .MoveFirst 'Устанавливаем строку
            i = rst.RecordCount 'определяем число записей
            funGetRows = rst.GetRows(i) 'Прочитываем данные
        End With
    End If
    rst.Close 'Закрываем запрос
    Set dbs = Nothing 'Закрываем базу
End Function

06. Используя небольшое количество графических функций отчета можно нарисовать линии, окружности и т.п.

'  Нарисовать объект (линию, прямоугольник) из таблицы
Private Sub newObject(rpt As Report, sTable As String)
Dim dbs As Database, rst As Recordset, i As Integer
Const PI = 3.14
    With rpt
        .ScaleMode = 6 'Рисуем в миллиметрах
        .FontName = "Arial" 'Выбираем шрифт
        .FontSize = 8 'Размер шрифта
        .ForeColor = 0 'Цвет объектов
    End With
    Set dbs = CurrentDb 'Текущая база данных
    Set rst = dbs.OpenRecordset(sTable) 'Открываем таблицу
    If rst.RecordCount  0 Then
        rst.MoveLast  'Заполняем запрос
        rst.MoveFirst 'Устанавливаем позицию
        For i = 0 To rst.RecordCount - 1 'Просматриваем запрос
          If rst!B = True Then 'Это прямоугольник
            rpt.Line (rst!x1, rst!y1)-(rst!x2, rst!y2), 0, B
          Else 'Это линия
            rpt.Line (rst!x1, rst!y1)-(rst!x2, rst!y2)
          End If
          rst.MoveNext 'Следующий элемент
        Next
    End If
    rst.Close
    'Рисуем окружность, элипс и дугу в радианах
    rpt.ForeColor = RGB(255, 0, 0) 'Красный цвет
    rpt.Circle (40, 20), 7 'Окружность
    rpt.ForeColor = RGB(0, 255, 0) 'Зеленый цвет
    rpt.Circle (40, 50), 20, , , , 0.5 'Элипс
    rpt.ForeColor = RGB(0, 0, 255) 'Синий цвет
    rpt.Circle (40, 50), 10, , PI / 2 + 0.5, PI, 0.5 'Дуга
End Sub

08. На этапе форматирования отчета, Вы можете управлять записями изменить их содержание или вообще не печатать. Такой метод позволяет Вам не менять запрос, а полностью перейти на управление отчетом из VBA

Private Sub ОбластьДанных_Format(Cancel As Integer, FormatCount As Integer)
    'Выбираем поле Даты и проверяем значения
    Select Case Me.Section(acDetail).Controls("Дата")
    Case Null 'Если нет даты, то отключаем запись
        Cancel = False
    Case Is = DateValue("31.12.1999") + 1 'Отображаем книги 2000 года
        Cancel = False 'Отключаем оставшиеся записи
    Case Else
        Cancel = True
    End Select
End Sub

22. Списки в формах могут иместь скрытие поля. О том, как можно их использовать указано в этом примере.

Private Sub butCalc_Click()
Dim i As Long, sum As Currency
    With Me.myList
        For i = 0 To .ListCount - 1
            sum = sum + .Column(1, i)
        Next
        MsgBox "Всего записей: "  .ListCount  ", выбран номер: "  .ListIndex  ", сумма="  sum
    End With
End Sub

07. 2 примера, один добавление из таблицы, а другой из файла показывают как можно внести в отчет логотипы и т.п.

' Из файла
Private Sub ОбластьДанных_Format(Cancel As Integer, FormatCount As Integer)
    Me.picFromFile.Picture = Application.CurrentProject.Path  _
                 "\"  Me.Рисунок
End Sub

'  Вставить рисунок из таблицы sTable
Private Sub InsertPicture(ctrl As Control, sTable As String)
Dim dbs As Database, rst As Recordset
    On Error GoTo 999 'Обработка ошибки
    Set dbs = CurrentDb 'Текущая база данных
    Set rst = dbs.OpenRecordset(sTable) 'Открываем таблицу
    If rst.RecordCount  0 Then
        rst.MoveLast  'Заполняем запрос
        rst.MoveFirst 'Устанавливаем позицию
        ctrl.Picture = Application.CurrentProject.Path  _
                 "\"  rst!Рисунок  'Полное имя файла
    End If
    rst.Close
999:
    Err.Clear 'Сброс ошибки
End Sub

07. Этот пример показывает, как в Access можно заполнить файл Excel разными способами: 1) Заполнение каждой ячейки своим значением 2) Заполнение ячеек из массива 3) Заполнение несколько ячеек 1 значением 4) Заполнение ячеек из ADODB.Recordset

'***************************************************************
'   Подписка:   "Access - программирование и готовые решения"
'   Тема:       "Клиенты автоматизации Access"
'   Версия:     1 от 16.07.2009
'   Автор:      Copyright © Leader Access, Ltd
'   Сайт:       http://www.leadersoft.ru

'***************************************************************
'  07. Пример. Вывод информации в Excel
'  Записывается информация о книгах по строкам,
'  используя разные варианты: Название, Цена, Автор, Пункт
'***************************************************************

Private Sub butOK_Click()
    On Error GoTo 999
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlFileName As String
     
    ' Определяем и проверяем имя файла
    xlFileName = Application.CurrentProject.Path  "\Книги.xls"
    If Dir(xlFileName, vbNormal) = "" Then
        MsgBox "Файл не найден: "  xlFileName, vbCritical, "http://www.leadersoft.ru"
        Exit Sub
    End If
    
    ' Устанавливаем ссылку на страницу
    Set xlApp = CreateObject("Excel.Application") ' Открываем Excel
    Set xlBook = xlApp.Workbooks.Open(FileName:=xlFileName) ' Открываем файл
    Set xlSheet = xlBook.Sheets("Мои книги") ' Выбираем лист книги
    xlApp.Visible = True ' Отображаем Excel

    ' Записываем данные в ячейки, пропустив строку заголовка
    ' 1 вариант. Сохраняем 1 значение ( 2 строка данных )
    xlSheet.Range("A2").Value = "Война и мир"
    xlSheet.Range("B2").Value = "200"
    xlSheet.Range("C2").Value = "Толстой"
    
    ' 2 вариант. Используем массив ( 3 строка данных )
    xlSheet.Range(xlSheet.Cells(3, 1), xlSheet.Cells(3, 3)).Value = _
        Array("Горе от ума", "150", "Грибоедов")
    
    ' 3 вариант. Используем одно значение ( Нумерация строк на листе )
    xlSheet.Range(xlSheet.Cells(2, 4), xlSheet.Cells(6, 4)).FormulaR1C1 = "=ROW()-1"

    ' 4 вариант. Используем запрос из базы данных ( 5 и 6 строка данных )
    Dim cn As ADODB.Connection, rs As New ADODB.Recordset, SQL As String
    Set cn = Application.CurrentProject.Connection
    SQL = "SELECT Книга,Сумма,Автор FROM [Пример 04] WHERE Len([Автор])  0"
    rs.Open SQL, cn
    xlSheet.Range("A5").CopyFromRecordset rs
    rs.Close
    Set rs = Nothing
    
' --- Закрываем  Excel и уничтожаем объекты, если это необходимо сделать автоматически ---
'    xlBook.Close SaveChanges:=True
'    xlApp.Quit
'    Set xlSheet = Nothing
'    Set xlBook = Nothing
'    Set xlApp = Nothing
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "http://www.leadersoft.ru"
    Err.Clear
End Sub