在64bitAccess中,原来32bit的Declare Function GetOpenFileName Lib “comdlg32.dll” 报错问题,可以通过下面方法解决:
第一步:在Delcare后面增加PtrSafe关键字
比如: Private Declare Function GetOpenFileName Lib “comdlg32.dll” Alias “GetOpenFileNameA” (pOpenfilename As OPENFILENAME) As Long
改为
Private Declare PtrSafe Function GetOpenFileName Lib “comdlg32.dll” Alias “GetOpenFileNameA” (pOpenfilename As OPENFILENAME) As Long
第二步:改Long类型为LongPtr
将OPENFILENAME的hwndOwner、hInstance、lpfnHook三个类型由long改为LongPtr
第三步:将lStructSize中的Len()改为LenB()
如:Len(fFileName)改为LenB(fFileName)
这样就解决了32bit系统可以运行,而64bit中无法运行的问题。
其它实例代码如下:
Option Compare Database
Option Explicit
Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare PtrSafe Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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
Const OFN_READONLY = &H1
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_SHOWHELP = &H10
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_NOVALIDATE = &H100
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_PATHMUSTEXIST = &H800
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_CREATEPROMPT = &H2000
Const OFN_SHAREAWARE = &H4000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOLONGNAMES = &H40000
Const OFN_EXPLORER = &H80000
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_LONGNAMES = &H200000
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0
Const MAX_PATH = 260
'strFilter = 僼傿儖僞暥帤
'strInitialDir = 弶婜僼傽僀儖
'strTitle = 僼傽僀儖僟僀傾儘僌偺僞僀僩儖
'strDefExt = 奼挘巕偑徣棯偝傟偨帪偺奼挘巕
'blOpen = 僼傽僀儖傪奐偔僟僀傾儘僌側傜 True
' 僼傽僀儖偺曐懚僟僀傾儘僌側傜 False
Function spFileDlg(strFilter As String, strInitialDir As String, strTitle As String, strDefExt As String, blOpen As Boolean, FN As String)
Dim fFileName As OPENFILENAME
Dim strBuff As String
Dim accWnd As Long
Dim lngRet As Long
accWnd = FindWindow("OMAIN", vbNullString)
strBuff = FN & String$(MAX_PATH - LenB(FN), 0)
With fFileName
.lStructSize = LenB(fFileName)
.hwndOwner = accWnd
.hInstance = 0
.lpstrFilter = strFilter
.nMaxCustFilter = 0&
.nFilterIndex = 0
.lpstrFile = strBuff
.nMaxFile = MAX_PATH
.lpstrFileTitle = String$(MAX_PATH, 0)
.nMaxFileTitle = MAX_PATH + 1
.lpstrInitialDir = strInitialDir
.lpstrTitle = strTitle
.flags = OFN_HIDEREADONLY
.lpstrDefExt = strDefExt
End With
If blOpen = True Then
lngRet = GetOpenFileName(fFileName)
Else
lngRet = GetSaveFileName(fFileName)
End If
If lngRet <> 0 Then
spFileDlg = fFileName.lpstrFile
Else
spFileDlg = "CANCEL"
End If
End Function
'僼傽僀儖?
'FN:棉太倌抬操?
'TL:擂脖鄹蘩材
'TP:抬操啦踢
'OP:False:弌椡(EXPORT)
' True :擖椡(IMPORT)
Function Get_FileName(FN As Variant, TL As Variant, TP As Variant, OP As Boolean, Optional DFLG As Boolean = True)
Dim ret As Variant
Dim S_DIR As String
Dim S_FN As String
Dim l As Integer
Dim FILENAME As String
Dim S_TL As String
Dim S_TP As String
Get_FileName = "CANCEL"
S_TL = TL
S_TP = TP
'弌?
If (IsNull(FN) Or (Len(Trim(FN)) = 0)) Then
S_DIR = ""
S_FN = ""
Else
l = 1
ret = 1
Do While (ret > 0)
ret = InStr(l, FN, "\")
If (IsNull(ret)) Then
S_DIR = ""
S_FN = ""
ret = 0
End If
If (ret = 0) Then
S_DIR = MID(FN, 1, l - 1)
S_FN = MID(FN, l)
End If
l = ret + 1
Loop
End If
Select Case TP
Case "TXT"
FILENAME = spFileDlg( _
"TextFile (*.txt)" & vbNullChar & "*.txt" & vbNullChar & "All File (*.*)" & vbNullChar & "*.*", _
S_DIR, _
S_TL, _
S_TP, _
OP, _
S_FN)
Case "CSV"
FILENAME = spFileDlg( _
"TextFile (*.csv)" & vbNullChar & "*.csv" & vbNullChar & "All File (*.*)" & vbNullChar & "*.*", _
S_DIR, _
S_TL, _
S_TP, _
OP, _
S_FN)
Case "XLS"
FILENAME = spFileDlg( _
"ExcelFile (*.xls)" & vbNullChar & "*.xls" & vbNullChar & "TEXT抬操 (*.csv)" & vbNullChar & "*.csv" & vbNullChar & "All File (*.*)" & vbNullChar & "*.*", _
S_DIR, _
S_TL, _
S_TP, _
OP, _
S_FN)
Case "MDB"
FILENAME = spFileDlg( _
"AccessFile (*.mdb)" & vbNullChar & "*.mdb" & vbNullChar & "All File (*.*)" & vbNullChar & "*.*", _
S_DIR, _
S_TL, _
S_TP, _
OP, _
S_FN)
Case Else
FILENAME = spFileDlg( _
"All File (*.*)" & vbNullChar & "*.*", _
S_DIR, _
S_TL, _
S_TP, _
OP, _
S_FN)
End Select
If FILENAME = "CANCEL" Then
Exit Function
End If
'僼傽僀儖柤挷?
ret = InStr(1, FILENAME, Chr(0))
If (IsNull(ret)) Then
Exit Function
Else
If (ret > 0) Then
FILENAME = MID(FILENAME, 1, ret - 1)
End If
End If
If (OP = False And DFLG) Then
If (Len(Dir(FILENAME)) > 0) Then
ret = MsgBox("OverWrite. OK?", vbYesNo, "OverWrite")
If (ret <> vbYes) Then
Exit Function
Else
Err = 0
On Error Resume Next
Kill FILENAME
On Error GoTo 0
If (Err <> 0) Then
ret = MsgBox("OverWrite Error. File Opened? ", , "OverWriteError")
Exit Function
End If
End If
End If
End If
Get_FileName = FILENAME
End Function