64位VBA调用打开和对话框
各位大侠，最近安装了Autocad 2018的VBA-64位模块，在利用VBA编程时发现缺少了Common Dialog控件，通过在网上学习得知此种情况下可以通过API实现调用相应对话框，但我通过下述代码调用时总是没有反应，请问这是怎么回事？谢谢Option Explicit
Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
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 Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
'
Public Function GetDialog(ByVal sMethod As String, ByVal sTitle As String, ByVal sFileName As String) As String
On Error GoTo myError
Dim rtn As Long, pos As Integer
Dim file As OPENFILENAME
file.lStructSize = Len(file)
'file.hInstance = Application.hInstance
file.hInstance = 0&
file.lpstrFile = sFileName & String$(255 - Len(sFileName), 0)
file.nMaxFile = 255
file.lpstrFileTitle = String$(255, 0)
file.nMaxFileTitle = 255
file.lpstrInitialDir = ""
file.lpstrFilter = "xls文件(*.xls)" '这个为xls文件
file.lpstrTitle = sTitle
If UCase(sMethod) = "OPEN" Then
file.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_FILEMUSTEXIST
rtn = GetOpenFileName(file)
Else
file.lpstrDefExt = "exe"
file.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_OVERWRITEPROMPT
rtn = GetSaveFileName(file)
End If
If rtn > 0 Then
pos = InStr(file.lpstrFile, Chr$(0))
If pos > 0 Then
GetDialog = Left$(file.lpstrFile, pos - 1)
End If
End If
Exit Function
myError:
MsgBox "操作失败！", vbCritical + vbOKOnly
End Function
调用程序为：
Private Sub CommandButton1_Click()
TextBox1.Text = GetDialog("open", "打开文件", "1.xls")
End Sub
Private Sub CommandButton2_Click()
TextBox2.Text = GetDialog("save", "保存文件", "1.xls")
End Sub
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Function ts_apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (tsFN As tsFileName) As Boolean
Public Declare PtrSafe Function ts_apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (tsFN As tsFileName) As Boolean
Public Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
#Else
Public Declare Function ts_apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (tsFN As tsFileName) As Boolean
Public Declare Function ts_apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (tsFN As tsFileName) As Boolean
Public Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
#End If
Public Type tsFileName
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
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 LongPtr
lpTemplateName As String
End Type
' Flag Constants
Public Const tscFNAllowMultiSelect = &H200
Public Const tscFNCreatePrompt = &H2000
Public Const tscFNExplorer = &H80000
Public Const tscFNExtensionDifferent = &H400
Public Const tscFNFileMustExist = &H1000
Public Const tscFNPathMustExist = &H800
Public Const tscFNNoValidate = &H100
Public Const tscFNHelpButton = &H10
Public Const tscFNHideReadOnly = &H4
Public Const tscFNLongNames = &H200000
Public Const tscFNNoLongNames = &H40000
Public Const tscFNNoChangeDir = &H8
Public Const tscFNReadOnly = &H1
Public Const tscFNOverwritePrompt = &H2
Public Const tscFNShareAware = &H4000
Public Const tscFNNoReadOnlyReturn = &H8000
Public Const tscFNNoDereferenceLinks = &H100000
Public Function tsGetFileFromUser( _
Optional ByRef rlngflags As Long = 0&, _
Optional ByVal strInitialDir As String = "", _
Optional ByVal strFilter As String = "All Files (*.*)" & vbNullChar & "*.*", _
Optional ByVal lngFilterIndex As Long = 1, _
Optional ByVal strDefaultExt As String = "", _
Optional ByVal strFileName As String = "", _
Optional ByVal strDialogTitle As String = "", _
Optional ByVal fOpenFile As Boolean = True) As Variant
'On Error GoTo tsGetFileFromUser_Err
Dim tsFN As tsFileName
Dim strFileTitle As String
Dim fResult As Boolean
' Allocate string space for the returned strings.
strFileName = Left(strFileName & String(256, 0), 256)
strFileTitle = String(256, 0)
' Set up the data structure before you call the function
With tsFN
.lStructSize = LenB(tsFN)
'.hwndOwner = Application.hWndAccessApp
.strFilter = strFilter
.nFilterIndex = lngFilterIndex
.strFile = strFileName
.nMaxFile = Len(strFileName)
.strFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.strTitle = strDialogTitle
.flags = rlngflags
.strDefExt = strDefaultExt
.strInitialDir = strInitialDir
.hInstance = 0
.strCustomFilter = String(255, 0)
.nMaxCustFilter = 255
.lpfnHook = 0
End With
' Call the function in the windows API
If fOpenFile Then
fResult = ts_apiGetOpenFileName(tsFN)
Else
fResult = ts_apiGetSaveFileName(tsFN)
End If
' If the function call was successful, return the FileName chosen
' by the user.Otherwise return null.Note, the CancelError property
' used by the ActiveX Common Dialog control is not needed.If the
' user presses Cancel, this function will return Null.
If fResult Then
rlngflags = tsFN.flags
tsGetFileFromUser = tsTrimNull(tsFN.strFile)
Else
tsGetFileFromUser = Null
End If
'tsGetFileFromUser_End:
' On Error GoTo 0
' Exit Function
'tsGetFileFromUser_Err:
' Beep
' MsgBox Err.Description, , "Error: " & Err.Number _
' & " in function basBrowseFiles.tsGetFileFromUser"
' Resume tsGetFileFromUser_End
End Function
' Trim Nulls from a string returned by an API call.
Private Function tsTrimNull(ByVal strItem As String) As String
On Error GoTo tsTrimNull_Err
Dim I As Integer
I = InStr(strItem, vbNullChar)
If I > 0 Then
tsTrimNull = Left(strItem, I - 1)
Else
tsTrimNull = strItem
End If
tsTrimNull_End:
On Error GoTo 0
Exit Function
tsTrimNull_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basBrowseFiles.tsTrimNull"
Resume tsTrimNull_End
End Function
'--------------------------------------------------------------------------
' Project : tsDeveloperTools
' Description: An example of how you can call tsGetFileFromUser()
' Calls :
' Accepts :
' Returns :
' Written By : Carl Tribble
' Date Created : 05/04/1999 11:19:41 AM
' Rev. History :
' Comments : This is provided merely as an example to the programmer
' It may be safely deleted from production code.
'--------------------------------------------------------------------------
Public Function tsGetFileFromUserTest(bOpen As Boolean, sFilter As String, sTitle As String) As String
On Error GoTo tsGetFileFromUserTest_Err
Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As Variant
' strFilter = "Access (*.mdb)" & vbNullChar & "*.mdb" _
' & vbNullChar & "All Files (*.*)" & vbNullChar & "*.*"
' strFilter = "All Files (*.*)" & vbNullChar & "*.*"
lngFlags = tscFNPathMustExist Or tscFNFileMustExist Or tscFNHideReadOnly
varFileName = tsGetFileFromUser( _
fOpenFile:=bOpen, _
strFilter:=sFilter, _
rlngflags:=lngFlags, _
strDialogTitle:=sTitle) '"GetFileFromUser Test (Please choose a file)"
If IsNull(varFileName) Then
'Debug.Print "User pressed 'Cancel'."
tsGetFileFromUserTest = ""
Exit Function
Else
'Debug.Print varFileName
'Forms!! = varFileName
If varFileName <> "" Then
tsGetFileFromUserTest = varFileName
Else
tsGetFileFromUserTest = ""
End If
Exit Function
End If
'If varFileName <> "" Then MsgBox "You selected the '" & varFileName & "' file.", vbInformation
tsGetFileFromUserTest_Err:
tsGetFileFromUserTest = ""
End Function Sub test()
Dim inputFileName As String
Dim strFilter As String
strFilter = "所有Excel文件 (*.xlsm,*.xlsx,*.xls)" & vbNullChar & "*.xlsm;*.xlsx;*.xls" & vbNullChar & "Excel文件 (*.xlsx)" & vbNullChar & "*.xlsx" & vbNullChar & "Excel97-2003 (*.xls)" & vbNullChar & "*.xls" _
& vbNullChar & "All Files (*.*)" & vbNullChar & "*.*"
inputFileName = tsGetFileFromUserTest(True, strFilter, "打开文件")
MsgBox inputFileName
End Sub 非常感谢SurveyCAD, 问题得到完美解决！
页:
[1]