Option Compare Database
Option Explicit
Private Const OFN_ALLOWMULTISELECT As Long = &H200
Private Const OFN_CREATEPROMPT As Long = &H2000
Private Const OFN_ENABLEHOOK As Long = &H20
Private Const OFN_ENABLETEMPLATE As Long = &H40
Private Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
Private Const OFN_FILEMUSTEXIST As Long = &H1000
Private Const OFN_HIDEREADONLY As Long = &H4
Private Const OFN_LONGNAMES As Long = &H200000
Private Const OFN_NOCHANGEDIR As Long = &H8
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_NOLONGNAMES As Long = &H40000
Private Const OFN_NONETWORKBUTTON As Long = &H20000
Private Const OFN_NOREADONLYRETURN As Long = &H8000&
Private Const OFN_NOTESTFILECREATE As Long = &H10000
Private Const OFN_NOVALIDATE As Long = &H100
Private Const OFN_OVERWRITEPROMPT As Long = &H2
Private Const OFN_PATHMUSTEXIST As Long = &H800
Private Const OFN_READONLY As Long = &H1
Private Const OFN_SHAREAWARE As Long = &H4000
Private Const OFN_SHAREFALLTHROUGH As Long = 2
Private Const OFN_SHAREWARN As Long = 0
Private Const OFN_SHARENOWARN As Long = 1
Private Const OFN_SHOWHELP As Long = &H10
Private Const OFS_MAXPATHNAME As Long = 260
#If Win64 Then
Private Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
Public Type OPENFILENAME
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
lpstrFilter As String
lpstrCustomFilter As String
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 LongPtr
lpTemplateName As String
End Type
Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As Boolean
#Else
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
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 String
End Type
Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Boolean
#End If
Public Const SW_HIDE = 0
Public Const SW_MINIMIZE = 6
Public Const SW_RESTORE = 9
Public Const SW_SHOW = 5
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_SHOWNOACTIVATE = 4
Public Const SW_SHOWNORMAL = 1
#If VBA7 Then
Public Declare PtrSafe 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
#Else
Public 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
#End If
#If VBA7 Then
Public Declare PtrSafe Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
#Else
Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
#End If
Public Function BrowseFolder(szDialogTitle As String) As String
Dim X As Long, BI As BROWSEINFO, dwIList As Variant
Dim szPath As String, wPos As Integer
With BI
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = &H1 Or &H40 ' &H40 adds the "Create New Folder" button
End With
dwIList = SHBrowseForFolder(BI)
szPath = VBA.Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If X Then
wPos = InStr(szPath, VBA.Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = vbNullString
End If
End Function
'This function shows the Windows Open File dialog with the specified
' parameters, and either returns the full path to the selected file,
' or an empty string if the user cancels.
Public Function OpenFile(ByVal Title As String, ByVal Filter As String, _
ByVal FilterIndex As Integer, ByVal StartPath As String, _
Optional OwnerForm As Form = Nothing) As String
'Create and populate an OPENFILENAME structure
'using the specified parameters
Dim ofn As OPENFILENAME
With ofn
.lStructSize = Len(ofn)
If OwnerForm Is Nothing Then
.hwndOwner = 0
Else
.hwndOwner = OwnerForm.hWnd
End If
.lpstrFilter = Filter
.nFilterIndex = FilterIndex
.lpstrFile = VBA.Space$(1024) & vbNullChar & vbNullChar
#If Win64 Then
.nMaxFile = LenB(.lpstrFile) - 1
.lStructSize = LenB(ofn)
#Else
.nMaxFile = Len(.lpstrFile) - 1
.lStructSize = Len(ofn)
#End If
.nMaxFile = Len(.lpstrFile)
.lpstrFileTitle = vbNullChar & VBA.Space$(512) & vbNullChar & vbNullChar
.nMaxFileTitle = Len(.lpstrFileTitle)
.lpstrInitialDir = StartPath & vbNullChar & vbNullChar
.lpstrTitle = Title
.flags = OFN_FILEMUSTEXIST
End With
'Call the Windows API function to show the dialog
If GetOpenFileName(ofn) = 0 Then
'The user pressed cancel, so return an empty string
OpenFile = vbNullString
Else
'The user selected a file, so remove the null-terminators
' and return the full path
OpenFile = VBA.Trim$(VBA.Left$(ofn.lpstrFile, Len(ofn.lpstrFile) - 2))
End If
End Function
Public Function SaveFile(ByVal Title As String, ByVal Filter As String, _
ByVal FilterIndex As Integer, ByVal StartPath As String, _
Optional OwnerForm As Form = Nothing) As String
'Create and populate an OPENFILENAME structure
'using the specified parameters
Dim ofn As OPENFILENAME
With ofn
.lStructSize = Len(ofn)
If OwnerForm Is Nothing Then
.hwndOwner = 0
Else
.hwndOwner = OwnerForm.hWnd
End If
.lpstrFilter = Filter
.nFilterIndex = FilterIndex
.lpstrFile = VBA.Space$(1024) & vbNullChar & vbNullChar
#If Win64 Then
.nMaxFile = LenB(.lpstrFile) - 1
.lStructSize = LenB(ofn)
#Else
.nMaxFile = Len(.lpstrFile) - 1
.lStructSize = Len(ofn)
#End If
.nMaxFile = Len(.lpstrFile)
.lpstrFileTitle = vbNullChar & VBA.Space$(512) & vbNullChar & vbNullChar
.nMaxFileTitle = Len(.lpstrFileTitle)
.lpstrInitialDir = StartPath & vbNullChar & vbNullChar
.lpstrTitle = Title
.flags = OFN_FILEMUSTEXIST
End With
'Call the Windows API function to show the dialog
If GetSaveFileName(ofn) = 0 Then
'The user pressed cancel, so return an empty string
SaveFile = vbNullString
Else
'The user selected a file, so remove the null-terminators
' and return the full path
SaveFile = VBA.Trim$(VBA.Left$(ofn.lpstrFile, Len(ofn.lpstrFile) - 2))
End If
End Function
הנושאים החמים
