64位VBA调用打开和对话框

craig_tao

各位大侠，最近安装了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

SurveyCAD

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![Form1]![Text1] = 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

SurveyCAD

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

craig_tao

非常感谢SurveyCAD, 问题得到完美解决！