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

06. В таблицах Access можно использовать разные цвета полей, для этого нужно знать их форматирование. Пример. !\ [Красный] или dd.mm.yyyy[Синий];;;"Нет даты". Для более детальной информации откройте этот пример.

если Вам необходимо из 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

04. Открыть таблицы базы данных можно по разному. Эти функции показывают, как можно это сделать из разных библиотек.

'==============================================================
' ADO. Использование таблиц
Private Sub butADO_Click()
Dim rst As ADODB.Recordset
    
    ' Включаем обработку ошибок
    On Error GoTo 999
    
    ' Создание запроса
    Set rst = New ADODB.Recordset
    
    ' Заполняем запрос
    With rst
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Source = "[Пример 04]"
        .Open , CurrentProject.Connection, , , adCmdTable
        If rst.RecordCount Then
            .MoveLast ' Заполнение запроса и расчет кол-ва записей
            .MoveFirst ' Начнем с первой записи
            Do Until .EOF
                ' Изменение записей
                rst!Описание = "ADO. Пример 04"
                rst.Update
                rst.MoveNext
            Loop
        End If
    End With
    
    ' Отображаем список
    Me.myList.RowSource = "ADODB. Изменение сделаны;Всего записей: "  Format(rst.RecordCount, "000")
    
    ' Конец просмотра
    rst.Close
    Set rst = Nothing
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

'==============================================================
' DAO. Использование таблиц
Private Sub butDAO_Click()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
    
    ' Включаем обработку ошибок
    On Error GoTo 999
    
    ' Создание запроса
    Set dbs = CurrentDb ' Текущая база данных
    Set rst = dbs.OpenRecordset("Пример 04", dbOpenTable)
    
    ' Заполняем запрос
    With rst
        If .RecordCount Then
            .MoveLast ' Заполнение запроса
            .MoveFirst ' Начнем с первой записи
            Do Until .EOF
                ' Изменение записей
                rst.Edit
                rst!Описание = "DAO. Пример 04"
                rst.Update
                rst.MoveNext
            Loop
        End If
    End With
    
    ' Отображаем список
    Me.myList.RowSource = "DAO. Изменения сделаны;Всего записей: "  Format(rst.RecordCount, "000")
    
    ' Конец просмотра
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

02. Есть таблица, в ней нужно провести поиск по нескольким полям. При этом задача должна решаться так, ввели 1 символ, таблица изменилаcь и показала все записи, где есть эта фраза (..\15 Формы\la_from.accdb\03. Контекстный поиск)

Option Compare Binary
Option Explicit
'Option Compare Text

'***************************************************************
' 3. Пример. Как создать контекстный поиск в Access
'   (смотрите также пример 2) ?
'***************************************************************

'==============================================================
' Открытие формы
Private Sub Form_Open(Cancel As Integer)
    Me.myFind3.Form.RecordSource = "SELECT Книга FROM [1-Мои книги]"
End Sub

'==============================================================
' Поиск с отбором книг
Private Sub myBooks_Change()
Dim s As String
    s = Me.myBooks.Text 'Определяем текст
    With Me.myFind3.Form 'Выбираем форму
      If Len(s)  0 Then
        s = " WHERE Left([Книга],"  Len(s)  ") = '"  s  "'"
      Else
        s = ";"
      End If
      .RecordSource = "SELECT Книга FROM [1-Мои книги]"  s
      .Requery 'Меняем запрос
    End With
End Sub

'==============================================================
' Контекстный поиск по книге
Private Sub Books_Change()
Dim rst As Recordset, frm As Form, s As String
    On Error GoTo 999
    Set frm = Me.myFind3.Form 'Выбираем форму
    Set rst = frm.RecordsetClone 'Выбираем таблицу
    
    rst.FindFirst "([Книга] Like '"  Me.Books.Text  "*')=True"
    If rst.NoMatch = False Then
        frm.Bookmark = rst.Bookmark
    End If
    Exit Sub
999:
    MsgBox "Введите правильно данные?"
End Sub

03. Данный пример показывает как можно быстро создать документ Word из Microsoft Access, используя шаблон *.dot. Для разметки документа используются специальные закладки.

'==============================================================
'   Создание документа Word по шаблону
'   • Для этого Вы должны создать в Word шаблон la_automat.dot
'   и поставить в нем Закладки, имеющие такие же имена как в форме.
'   Например, Вставка - Закладка ... - Имя закладки=Фирма
'   (Нажмите кнопку Добавить и сохраните шаблон)
'
Private Sub butNewWord_Click()
Dim app As Word.Application  'Приложение программы
Dim strDOC As String ' Имя документа
Dim strDOT As String ' Имя шаблона
Dim ctl As Control ' Управляющие элементы в форме
Dim s As String ' Вспомогательная строка
    
    On Error GoTo 999
    ' Определяем имена шаблона и документа Word
    With Application.CurrentProject
        strDOT = .Path  "\"  "la_automat.dot"
        strDOC = .Path  "\"  "la_automat.doc"
    End With
    
    ' Управление документом Word
    Set app = New Word.Application 'Новое приложение Word
    app.Visible = True 'Отображаем документ
    app.Documents.Add strDOT 'Добавляем шаблон
    With app.ActiveDocument  'Выбираем активный документ
        On Error Resume Next ' Отключаем ошибки
        ' Просматриваем все элементы формы, если
        ' такой закладки нет, то очищаем поток от ошибки
        For Each ctl In Me.Controls
            If ctl.ControlType = acTextBox Then
                s = ctl.Name ' Определяем название элемента
                .Bookmarks.Item(s).Range.Text = Me(s) 'Устанавливаем текст
                Err.Clear ' Очищаем поток от ошибки при отсутствии элемента
            End If
        Next ctl
        .SaveAs strDOC ' Сохраняем файл
        On Error GoTo 999 ' Включаем обработку ошибки
    End With
    ' app.Quit 'Закрываем приложение
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
    app.Quit
End Sub

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

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

04. Пример показывает Вам как определить разрешение экрана окна формы.

Private Declare Function apiGetSystemMetrics Lib "user32" Alias "GetSystemMetrics" _
 (ByVal nIndex As Long) As Long

'==============================================================
'   Получить разрешение экрана
Private Sub кнОткрыть_Click()
    Me.myMemo.Caption = "Разрешение по X: "  _
                apiGetSystemMetrics(0)  vbCrLf
    Me.myMemo.Caption = Me.myMemo.Caption  _
                        "Разрешение по Y: "  _
                apiGetSystemMetrics(1)
End Sub

03. Если Вас не устраивает однотипный цвет таблиц запросов, то использование этого метода позволит вам раскрасить отдельные поля запроса.

'==============================================================
'   Установить формат поля
Private Sub butExecute_Click()
Dim dbs As Database, obj As Object
    On Error GoTo 999
        Set dbs = CurrentDb
        Set obj = dbs.QueryDefs("Запрос 03").Fields("Сумма03")
        SetFieldProperty obj, "Format", dbChar, "0.00;0.00;0.00;0[Red]"
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "Изменение поля"
    Err.Clear
End Sub

'==============================================================
'   Удалить формат поля
Private Sub butDelProp_Click()
Dim dbs As Database, obj As Object
    On Error GoTo 999
        Set dbs = CurrentDb
        Set obj = dbs.QueryDefs("Запрос 03").Fields("Сумма03")
        SetFieldProperty obj, "Format", dbChar, "0;0;0"
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "Удаление поля"
    Err.Clear
End Sub

'==============================================================
'   Установить свойство поля запроса
Private Sub SetFieldProperty(obj As Object, _
        prpName As String, _
        prpType As Integer, _
        prpValue As Variant)
Dim prp As Variant
    On Error GoTo 999
    obj.Properties(prpName) = prpValue
    obj.Properties.Refresh
    MsgBox "Свойство изменено!", vbExclamation, "Свойства"
    Exit Sub
999:
    Err.Clear
    Set prp = obj.CreateProperty(prpName, prpType, prpValue)
    obj.Properties.Append prp
    obj.Properties.Refresh
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

08. Очень часто встречается так, что одна таблица подчиняется другой. Например, накладные, а у них есть спецификация. Если создать соотношение один ко многим, то у таблицы появляется поле [+]. Нажав на него, можно увидеть подчиненную таблицу.