Kod:
Option Compare Database
#If VBA7 Then
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10
Const ALLFILES = "All Files"
Private Type CLTAPI_OPENFILE
strFilter As String
intFilterIndex As LongPtr
strInitialDir As String
strInitialFile As String
strDialogTitle As String
strDefaultExtension As String
lngFlags As LongPtr
strFullPathReturned As String
strFileNameReturned As String
intFileOffset As Integer
intFileExtension As Integer
End Type
Private Type CLTAPI_WINOPENFILENAME
lStructSize As LongPtr
hwndOwner As LongPtr
hInstance As LongPtr
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustrFilter As LongPtr
nFilterIndex As LongPtr
lpstrFile As String
nMaxFile As LongPtr
lpstrFileTitle As String
nMaxFileTitle As LongPtr
lpstrInitialDir As String
lpstrTitle As String
Flags As LongPtr
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustrData As LongPtr
lpfnHook As LongPtr
lpTemplateName As String
End Type
'Sistemsel Olaylar Tanımlanıyor...
Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As LongPtr) As LongPtr
Declare PtrSafe Function CLTAPI_GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As CLTAPI_WINOPENFILENAME) As Boolean
Declare PtrSafe Function CLTAPI_GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As CLTAPI_WINOPENFILENAME) As Boolean
Declare PtrSafe Sub CLTAPI_ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hwnd As LongPtr, rgb As LongPtr)
#Else
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10
Const ALLFILES = "All Files"
Private Type CLTAPI_OPENFILE
strFilter As String
intFilterIndex As Long
strInitialDir As String
strInitialFile As String
strDialogTitle As String
strDefaultExtension As String
lngFlags As Long
strFullPathReturned As String
strFileNameReturned As String
intFileOffset As Integer
intFileExtension As Integer
End Type
Private Type CLTAPI_WINOPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustrFilter 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
lCustrData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'Sistemsel Olaylar Tanımlanıyor...
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Declare Function CLTAPI_GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As CLTAPI_WINOPENFILENAME) As Boolean
Declare Function CLTAPI_GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As CLTAPI_WINOPENFILENAME) As Boolean
Declare Sub CLTAPI_ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hwnd As Long, rgb As Long)
#End If
'Const OFN_ALLOWMULTISELECT = &H200
'Const OFN_CREATEPROMPT = &H2000
'Const OFN_EXPLORER = &H80000
'Const OFN_FILEMUSTEXIST = &H1000
'Const OFN_HIDEREADONLY = &H4
'Const OFN_NOCHANGEDIR = &H8
'Const OFN_NODEREFERENCELINKS = &H100000
'Const OFN_NONETWORKBUTTON = &H20000
'Const OFN_NOREADONLYRETURN = &H8000
'Const OFN_NOVALIDATE = &H100
'Const OFN_OVERWRITEPROMPT = &H2
'Const OFN_PATHMUSTEXIST = &H800
'Const OFN_READONLY = &H1
'Const OFN_SHOWHELP = &H10
'Const ALLFILES = "All Files"
'
'Private Type CLTAPI_OPENFILE
' strFilter As String
' intFilterIndex As LongPtr
' strInitialDir As String
' strInitialFile As String
' strDialogTitle As String
' strDefaultExtension As String
' lngFlags As LongPtr
' strFullPathReturned As String
' strFileNameReturned As String
' intFileOffset As Integer
' intFileExtension As Integer
'End Type
'
'Private Type CLTAPI_WINOPENFILENAME
' lStructSize As LongPtr
' hwndOwner As LongPtr
' hInstance As LongPtr
' lpstrFilter As String
' lpstrCustomFilter As String
' nMaxCustrFilter As LongPtr
' nFilterIndex As LongPtr
' lpstrFile As String
' nMaxFile As LongPtr
' lpstrFileTitle As String
' nMaxFileTitle As LongPtr
' lpstrInitialDir As String
' lpstrTitle As String
' Flags As LongPtr
' nFileOffset As Integer
' nFileExtension As Integer
' lpstrDefExt As String
' lCustrData As LongPtr
' lpfnHook As LongPtr
' lpTemplateName As String
'End Type
'
''Sistemsel Olaylar Tanımlanıyor...
'Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As LongPtr) As LongPtr
'Declare PtrSafe Function CLTAPI_GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As CLTAPI_WINOPENFILENAME) As Boolean
'Declare PtrSafe Function CLTAPI_GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As CLTAPI_WINOPENFILENAME) As Boolean
'Declare PtrSafe Sub CLTAPI_ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hwnd As LongPtr, rgb As LongPtr)
Function GetOpenFile_CLT(strInitialDir As String, strTitle As String) As String
Dim fOK As Boolean
Dim typWinOpen As CLTAPI_WINOPENFILENAME
Dim typOpenFile As CLTAPI_OPENFILE
Dim strFilter As String
On Error GoTo PROC_ERR
strFilter = CreateFilterString_CLT("All Files (*.*)", "*.*", "Database Files (*.accdb)", "*.accdb", "Database Files (*.accde)", "*.accde", "Database Files (*.mdb)", "*.mdb", "Database Files (*.mde)", "*.mde")
If strInitialDir <> "" Then
typOpenFile.strInitialDir = strInitialDir
Else
typOpenFile.strInitialDir = CurDir()
End If
If strTitle <> "" Then
typOpenFile.strDialogTitle = strTitle
End If
typOpenFile.strFilter = strFilter
typOpenFile.lngFlags = OFN_HIDEREADONLY Or OFN_SHOWHELP
ConvertCLT2Win typOpenFile, typWinOpen
fOK = CLTAPI_GetOpenFileName(typWinOpen)
ConvertWin2CLT typWinOpen, typOpenFile
GetOpenFile_CLT = typOpenFile.strFullPathReturned
PROC_EXIT:
Exit Function
PROC_ERR:
GetOpenFile_CLT = ""
Resume PROC_EXIT
End Function
Sub ConvertCLT2Win(CLT_Struct As CLTAPI_OPENFILE, Win_Struct As CLTAPI_WINOPENFILENAME)
Dim strFile As String * 512
On Error GoTo PROC_ERR
Win_Struct.hwndOwner = Application.hWndAccessApp
Win_Struct.hInstance = 0
If CLT_Struct.strFilter = "" Then
Win_Struct.lpstrFilter = ALLFILES & Chr$(0) & "*.*" & Chr$(0)
Else
Win_Struct.lpstrFilter = CLT_Struct.strFilter
End If
Win_Struct.nFilterIndex = CLT_Struct.intFilterIndex
Win_Struct.lpstrFile = String(512, 0)
Win_Struct.nMaxFile = 511
Win_Struct.lpstrFileTitle = String$(512, 0)
Win_Struct.nMaxFileTitle = 511
Win_Struct.lpstrTitle = CLT_Struct.strDialogTitle
Win_Struct.lpstrInitialDir = CLT_Struct.strInitialDir
Win_Struct.lpstrDefExt = CLT_Struct.strDefaultExtension
Win_Struct.Flags = CLT_Struct.lngFlags
Win_Struct.lStructSize = Len(Win_Struct)
PROC_EXIT:
Exit Sub
PROC_ERR:
Resume PROC_EXIT
End Sub
Sub ConvertWin2CLT(Win_Struct As CLTAPI_WINOPENFILENAME, CLT_Struct As CLTAPI_OPENFILE)
On Error GoTo PROC_ERR
CLT_Struct.strFullPathReturned = Left(Win_Struct.lpstrFile, InStr(Win_Struct.lpstrFile, vbNullChar) - 1)
CLT_Struct.strFileNameReturned = RemoveNulls_CLT(Win_Struct.lpstrFileTitle)
CLT_Struct.intFileOffset = Win_Struct.nFileOffset
CLT_Struct.intFileExtension = Win_Struct.nFileExtension
PROC_EXIT:
Exit Sub
PROC_ERR:
Resume PROC_EXIT
End Sub
Function CreateFilterString_CLT(ParamArray varFilt() As Variant) As String
Dim strFilter As String
Dim intCounter As Integer
Dim intParamCount As Integer
On Error GoTo PROC_ERR
intParamCount = UBound(varFilt)
If (intParamCount <> -1) Then
For intCounter = 0 To intParamCount
strFilter = strFilter & varFilt(intCounter) & Chr$(0)
Next
If (intParamCount Mod 2) = 0 Then
strFilter = strFilter & "*.*" & Chr$(0)
End If
End If
CreateFilterString_CLT = strFilter
PROC_EXIT:
Exit Function
PROC_ERR:
CreateFilterString_CLT = ""
Resume PROC_EXIT
End Function
Function RemoveNulls_CLT(strIn As String) As String
Dim intChr As Integer
intChr = InStr(strIn, Chr$(0))
If intChr > 0 Then
RemoveNulls_CLT = Left$(strIn, intChr - 1)
Else
RemoveNulls_CLT = strIn
End If
End Function
ile komple değiştiriniz.