Разделы
Главная

Windows API
Реестр
MS Access
Visual Basic
Download
Форум
Гостевая книга
Ссылки

E-mail

Партнерская программа WWW.PORTA.RU (on-line магазин портативной аудио, видео, фототехники). Самая щедрая, самая честная, самая популярная. Приглашаем всех веб-мастеров к участию!



Submitter.ru - Free promoting
MS Access

вернуться назад Выбор файла
Текст модуля:

Option Compare Database
Option Explicit

' выбор файла
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


Выбор файла (37 396 байт)