' выбор файла
Type tagOPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Sub OpenFile()
Dim strFilter As String
Dim lngFlags As Long
strFilter = ahtAddFilterItem(strFilter, "Access Files (*.mda, *.mdb)", _
"*.MDA;*.MDB")
strFilter = ahtAddFilterItem(strFilter, "dBASE Files (*.dbf)", "*.DBF")
strFilter = ahtAddFilterItem(strFilter, "Text Files (*.txt)", "*.TXT")
strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")
Forms!Выбор_файла!Поле0.SetFocus
Forms!Выбор_файла!Поле0.Text = ahtCommonFileOpenSave(InitialDir:="C:\", _
Filter:=strFilter, FilterIndex:=1, Flags:=lngFlags, _
DialogTitle:="Выбор файла")
End Sub
Private Function ahtAddFilterItem(strFilter As String, _
strDescription As String, Optional varItem As Variant) As String
If IsMissing(varItem) Then varItem = "*.*"
ahtAddFilterItem = strFilter & _
strDescription & vbNullChar & varItem & vbNullChar
End Function
Private Function ahtCommonFileOpenSave( _
Optional ByRef Flags As Variant, _
Optional ByVal InitialDir As Variant, _
Optional ByVal Filter As Variant, _
Optional ByVal FilterIndex As Variant, _
Optional ByVal DefaultExt As Variant, _
Optional ByVal FileName As Variant, _
Optional ByVal DialogTitle As Variant, _
Optional ByVal Hwnd As Variant, _
Optional ByVal OpenFile As Variant) As Variant
Dim strFilename As String
Dim strFileTitle As String
Dim fResult As Boolean
Dim OFN As tagOPENFILENAME
If IsMissing(InitialDir) Then InitialDir = CurDir
If IsMissing(Filter) Then Filter = ""
If IsMissing(FilterIndex) Then FilterIndex = 1
If IsMissing(Flags) Then Flags = 0&
If IsMissing(DefaultExt) Then DefaultExt = ""
If IsMissing(FileName) Then FileName = ""
If IsMissing(DialogTitle) Then DialogTitle = ""
If IsMissing(Hwnd) Then Hwnd = Application.hWndAccessApp
If IsMissing(OpenFile) Then OpenFile = True
strFilename = Left(FileName & String(256, 0), 256)
strFileTitle = String(256, 0)
With OFN
.lStructSize = Len(OFN)
.hwndOwner = Hwnd
.strFilter = Filter
.nFilterIndex = FilterIndex
.strFile = strFilename
.nMaxFile = Len(strFilename)
.strFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.strTitle = DialogTitle
.Flags = Flags
.strDefExt = DefaultExt
.strInitialDir = InitialDir
.hInstance = 0
.strCustomFilter = ""
.nMaxCustFilter = 0
.lpfnHook = 0
.strCustomFilter = String(255, 0)
.nMaxCustFilter = 255
End With
If OpenFile Then
fResult = aht_apiGetOpenFileName(OFN)
Else
fResult = aht_apiGetSaveFileName(OFN)
End If
If Not IsMissing(Flags) Then
Flags = OFN.Flags
ahtCommonFileOpenSave = TrimNull(OFN.strFile)
Else
ahtCommonFileOpenSave = vbNullString
End If
End Function
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
intPos = InStr(strItem, vbNullChar)
If intPos > 0 Then
TrimNull = Left(strItem, intPos - 1)
Else
TrimNull = strItem
End If
End Function
Текст формы:
Option Compare Database
Option Explicit
' выбор файла
' для работы необходимо в форму добавить:
' Поле с именем Поле0 и
' кнопку с именем Кнопка2
Private Sub Кнопка2_Click()
On Error GoTo Err_Кнопка2_Click
' выбираем файл
Call OpenFile
Exit_Кнопка2_Click:
Exit Sub
Err_Кнопка2_Click:
Resume Exit_Кнопка2_Click
End Sub