通用(32位、64位) CAD VBA(6.0、7.0)实现打开、另存、选择文件夹对话框

         vba可以调用windows API函数实现弹出打开文件、另存文件及选择文件夹对话框,然而低版本CAD(32位CAD,对应VBA6)写的代码到高版本CAD(64位,对应VBA7)往往运行不了,提示各种错误。

        不同版本的VBA写出的DVB文件不能通用往往令人懊恼,而网上给出的解决办法也是只言片语,很难彻底解决这一难题。不要灰心,这里给出终极代码。

        话不多说,先上效果图:

VB6在CAD2007下运行效果图:

 

32位、64位CADVBA均可行

以下是vb7.0 ,在CAD2024版本上运行结果:

 

 

代码附上:

Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function ts_apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (tsFN As tsFileName) As Boolean
Private Declare PtrSafe Function ts_apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (tsFN As tsFileName) As Boolean
Private Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Type BROWSEINFO
            hOwner As LongPtr
            pidlRoot As LongPtr
            pszDisplayName As String
            lpszTitle As String
            ulFlags As LongPtr
            lpfn As LongPtr
            lParam As LongPtr
            iImage As LongPtr
End Type
Private Type tsF
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''
''''
''''
''''
'''
'''完整代码联系本博qq443440204
'''
'''
'''
'''
'''
'''
'''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    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
     
    Dim sFileName As String
    If GetSaveFileName(sSFN) <> 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
#End If

Sub a()
On Error GoTo errorcontrol
MsgBox GOFOLDER
Documents.Open GOFN
ThisDrawing.SaveAs GSFN
Exit Sub
errorcontrol: MsgBox Err.Number & " - " & Err.Description
End

End Sub





版权所有qq:443440204,如有引用,请注明出处!

评论 6
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包

打赏作者

山水CAD插件定制

你的鼓励是我创作最大的动力!

¥1 ¥2 ¥4 ¥6 ¥10 ¥20
扫码支付:¥1
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值