11. Выделить всю строки в форме возможно, если Вы используете программных код указанный в описании.
Private Sub Form_Current()
Dim N As Long
On Error Resume Next
Me.Repaint
N = Me.SelTop
If N 1 Then N = 1
Me.SelTop = N
Me.SelLeft = 1
Me.SelWidth = 10
Me.SelHeight = 1
Err.Clear
End Sub
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
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
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
Для быстрого запуска приложения из 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 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
Для быстрой загрузки всех файлов в таблицу можно использовать этот способ. Применяйте его, например, для обработки 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
Этот пример покажет Вам как управлять бинарными файлами из 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 управлять файлами, то этот набор функций раскажет как это сделать. Вы сможете удалять, создавать и копировать папки.
' Создание пустой папки
' 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
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