Option Compare Database
' This code is licensed according to the terms and conditions listed here.
' Declarations and such needed for the example:
' (Copy them to the (declarations) section of a module.)
Public Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustomFilter 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 String
End Type
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_PATHMUSTEXIST = &H800
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (lpofn _
As OPENFILENAME) As Long
Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
'ADD LISTBOX HEIGHT CHANGER
'Public Declare Function SendMessage Lib "comdlg32.dll" Alias "SendMessageA" (ByVal _
' hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
' lParam As Any) As Long
'Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal _
' hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
' lParam As Any) As Long
'Const LB_SETITEMHEIGHT = &H1A0
'Const CB_SETITEMHEIGHT = &H153
' Set the height in pixels of each entry in a ListBox or ComboBox control
'Sub SetListItemHeight(ctrl As Control, ByVal newHeight As Long)
' Dim uMsg As Long
' If TypeOf ctrl Is ListBox Then
' uMsg = LB_SETITEMHEIGHT
' ElseIf TypeOf ctrl Is ComboBox Then
' uMsg = CB_SETITEMHEIGHT
' Else
' Exit Sub
' End If
' ' (only the low-order word of lParam can be used.)
' SendMessage ctrl.hwnd, uMsg, 0, ByVal CLng(newHeight And &HFFFF&)
' ' It is necessary to manually refresh the control.
' ctrl.Refresh
'End Sub
Function GetFileName(Optional strIntype As String, Optional DBProjectName)
'Set Variables for Document Name
Dim filebox As OPENFILENAME ' open file dialog structure
Dim fname As String ' filename the user selected
Dim result As Long ' result of opening the dialog
Dim SaveAsName As String ' file to save in the dialog
Dim ExtName As String
'On Error GoTo Err_Command5_Click
'Make Reference to Microsoft Word XX object Library
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
'Get document Name
' Configure how the dialog box will look
With filebox
' Size of the structure.
.lStructSize = Len(filebox)
' Handle to window opening the dialog.
.hwndOwner = hwnd 'Me.Hwnd
' Handle to calling instance (not needed).
.hInstance = 0
' File filters to make available: Text Files and All Files
.lpstrFilter = "Excel Files (*.xls)" & vbNullChar & "*.xls" & vbNullChar & vbNullChar
If strIntype = "mdb" Then
.lpstrFilter = "Access Files (*.mdb)" & vbNullChar & DBProjectName & vbNullChar & vbNullChar
End If
.nMaxCustomFilter = 0
' Default filter is the first one (Text Files, in this case).
.nFilterIndex = 1
' No default filename. Also make room for received
' path and filename of the user's selection.
.lpstrFile = Space(256) & vbNullChar
.nMaxFile = Len(.lpstrFile)
' Make room for filename of the user's selection.
.lpstrFileTitle = Space(256) & vbNullChar
.nMaxFileTitle = Len(.lpstrFileTitle)
' Initial directory is C:\.
.lpstrInitialDir = "C:\" & vbNullChar
' Title of file dialog.
.lpstrTitle = "Select the File to be searched" & vbNullChar
' The path and file must exist; hide the read-only box.
.flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
' The rest of the options aren't needed.
.nFileOffset = 0
.nFileExtension = 0
'.lpstrDefExt is ignored -- unused string
.lCustData = 0
.lpfnHook = 0
'.lpTemplateName is ignored -- unused string
End With
' Display the dialog box.
result = GetOpenFileName(filebox)
If result <> 0 Then
' Remove null space from the file name.
fname = Left(filebox.lpstrFile, InStr(filebox.lpstrFile, vbNullChar) - 1)
ExtName = right(fname, 3)
fnameext = ExtName
'Debug.Print "The selected file: "; fname
End If
GetFileName = fname
'ImportFileNameField = fname
' With filebox
' .lpstrInitialDir = "C:\temp\" & vbNullChar
' .lpstrFile = "C:\Temp\WordToAccess.txt" & vbNullChar
' .lpstrFilter = "Text (*.txt)" & vbNullChar & "*.txt" & vbNullChar & vbNullChar
' End With
'result = GetSaveFileName(filebox)
'If result <> 0 Then
'' Remove null space from the file name.
'SaveAsName = Left(filebox.lpstrFile, InStr(filebox.lpstrFile, vbNullChar) - 1)
'ExtName = Right(fname, 3)
'fnameext = ExtName
'Debug.Print "The selected file: "; fname
'End If
End Function
|