CAD VBA(6.0)调用api函数实现打开、另存对话框（vba7.0版本请参考另一篇文章https://blog.csdn.net/yongshiqq/article/details/13462）

效果图及代码

（vba7.0以上版本请参考另一篇文章通用（32位、64位） CAD VBA(6.0、7.0)实现打开、另存、选择文件夹对话框-CSDN博客）

笔者为VBA小白一枚，在近期的vba学习当中，发现如下问题：Excel vba 中自带 FileDialog函数，很容易实现打开、另存对话框，而CAD VBA中无法使用此函数弹出对话框，需调用windows api函数(GetOpenFileName、GetSaveFileName)。功夫不负有心人，经笔者反复查阅资料并调试，历时6天终于成功实现，当弹出对话框的那一刻，大喜，如下图所示：

现分享代码如下（若需引用发布，务必附本文网址链接注明出处）：

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (lpofn As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (lpofn As OPENFILENAME) As Long
 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
Function GOFN() As String
    Dim sOFN As OPENFILENAME
    With sOFN
        .lStructSize = Len(sOFN)
        
       .lpstrFilter = "dwg文件(*.dwg)" & Chr(0) & "*.dwg" & Chr(0) & "dxf文件(*.dxf)" & Chr(0) & "*.dxf" & Chr(0) & "Excel文件(*.xl*)" & Chr(0) & "*.xl*" & Chr(0) & "Word文件(*.do*)" _
        & Chr(0) & "*.do*" & Chr(0) & "PPT文件(*.pp*)" & Chr(0) & "*.pp*" & Chr(0) & "所有文件(*.*)" & Chr(0) & "*.*" _
        & Chr(0) & Chr(0)
        .lpstrFile = Space(1024)
        .nMaxFile = 1025
    End With
    i = GetOpenFileName(sOFN)
    If i <> 0 Then
        With sOFN
            sFileName = Trim(.lpstrFile)
            GOFN = Left(sFileName, Len(sFileName) - 1)
        End With
    Else
        GOFN = ""
          MsgBox "您已取消，请重新选择"
        End
    End If
End Function
Function GSFN() As String
    Dim sSFN As OPENFILENAME
    With sSFN
        .lStructSize = Len(sSFN)
        '设置保存文件对话框中的文件筛选字符串对
       .lpstrFilter = "dwg文件(*.dwg)" & Chr(0) & "*.dwg" & Chr(0) & "dxf文件(*.dxf)" & Chr(0) & "*.dxf" & Chr(0) & "Excel文件(*.xl*)" & Chr(0) & "*.xl*" & Chr(0) & "Word文件(*.do*)" _
        & Chr(0) & "*.do*" & Chr(0) & "PPT文件(*.pp*)" & Chr(0) & "*.pp*" & Chr(0) & "所有文件(*.*)" & Chr(0) & "*.*" _
        & Chr(0) & Chr(0)
        '设置文件完整路径和文件名的缓冲区
        .lpstrFile = Space(1024)
        '设置文件完整路径和文件名的最大字符数,一定要比lpstrFile参数指定的字符数多1，用于存储结尾Null字符
        .nMaxFile = 1025
    End With
    i = GetSaveFileName(sSFN)
    
    If i <> 0 Then
        With sSFN
            sFileName = Trim(.lpstrFile)
            GSFN = Left(sFileName, Len(sFileName) - 1)
        End With
    Else
        GSFN = ""
        MsgBox "您已取消，请重新选择"
        End
       
    End If
'    Debug.Print GSFN, Len(GSFN)

End Function

Sub a()
Documents.Open GOFN
ThisDrawing.SaveAs GSFN & ".dwg"
End Sub

 另附Excel VBA 中打开及另存对话框实例代码：

Sub 打开文件对话框()
On Error Resume Next
With Application.FileDialog(msoFileDialogOpen)
    .Title = "请选择你要的文件"
    .AllowMultiSelect = True
    .InitialFileName = "C:\Users\Administrator\Desktop\"
    .Filters.Clear
    .Filters.Add "excel files", "*.xls,*.xlsx,*.dwg"
    If .Show = True Then
    Set gof = .SelectedItems
    .Execute
    Else: Exit Sub
    End If
End With
ActiveSheet.Cells(11, 5).Value = gof.Item(1)
MsgBox "另存为"
With Application.FileDialog(msoFileDialogSaveAs)
    .Title = "另存为"
    .AllowMultiSelect = True
    .InitialFileName = "C:\Users\Administrator\Desktop\"
   
    If .Show = True Then
    Set gof = .SelectedItems
    .Execute
    Else: Exit Sub
    End If
End With
'ActiveWorkbook.Close
End Sub