AutoCAD VBA部署方案分享

通过创建快捷方式用于加载dvb，写入菜单

1’通过代码编写scr文件和创建dvb工程加载快捷方式

"C:\Program Files\Autodesk\AutoCAD 2022\acad.exe" /nologo /b "D:\VBProject\AutoCADVbaProject\MyVbaCmd_2022\算法研究.scr"

/nologo 表示启动跳过界面加快cad的启动速度

/b 表示需要启动cad的时候，加载二进制程序

具体参考官方说明

https://knowledge.autodesk.com/zh-hans/support/autocad/learn-explore/caas/CloudHelp/cloudhelp/2018/CHS/AutoCAD-Core/files/GUID-8E54B6EC-5B52-4F62-B7FC-0D4E1EDF093A-htm.html

2.scr文件的内部如下

创建快捷方式

 Public Sub Mycmd_创建DVB加载快捷方式()
    Dim curDvbName As String, fso As New FileSystemObject, scrFn As String, dvbName As String
    curDvbName = Application.VBE.ActiveVBProject.FileName
    '创建scr文件
    scrFn = VBA.Replace(curDvbName, ".dvb", ".scr")
    dvbName = VBA.Replace(fso.GetFileName(curDvbName), ".dvb", vbNullString)
    Open scrFn For Output As #1                                '如改为For Append，则为追加文件。
    Print #1, "filedia 0"
    Print #1, "cmdecho 0"
    Print #1, "_vbarun " & Chr(34) & VBA.Replace(curDvbName, "\", "/") & "!ThisDrawing.AddBar" & Chr(34)    'addbar表示需要随cad启动而执行的过程
    Print #1, "filedia 1"
    Close #1
    
    '创建快捷方式
    Dim wsh As Object, lnkFilePath As String, shortCut As Object
    Set wsh = VBA.CreateObject("WScript.Shell")                ''IWshRuntimeLibrary;C:\Windows\SysWOW64\wshom.ocx
    lnkFilePath = wsh.SpecialFolders("Desktop") & "\" & VBA.Replace(dir(curDvbName), ".dvb", "(" & fso.GetFolder(Application.Path).Name & ").lnk")    '创建快捷方式到桌面
    '关于SpecialFolders 查看下面的网站即可查阅
    Rem https://www.vbsedit.com/html/7682257e-4042-4f7d-b266-03382021d0aa.asp
    'var startMenuDir = $@"C:\ProgramData\Microsoft\Windows\Start Menu\Programs";
    '"C:\Program Files (x86)\AutoCAD 2008\acad.exe" /nologo /b "C:\Users\NanSheng\AppData\Local\Temp\算法研究.scr"
    With wsh.CreateShortcut(lnkFilePath)
        .TargetPath = Chr(34) & Application.FullName & Chr(34)
        .Arguments = "/nologo /b " & Chr(34) & scrFn & Chr(34)
        .WorkingDirectory = fso.GetParentFolderName(scrFn)
        .WindowStyle = 1                                       '//设置运行方式，默认为常规窗口                        '// '设置备注
        '//shortcut.IconLocation = String.IsNullOrWhiteSpace(iconLocation) ? targetPath : iconLocation;//设置图标路径
        .Save
    End With
    Set wsh = Nothing
End Sub

创建菜单的主过程，这个也是在scr中需要与cad启动同时执行的过程

此处开发者需要根据需要自己设定需要加载到菜单的方法的规则

 Public Sub AddBar()
    Dim mycmds As Dictionary, menuName As String, vbeobj As Object, curDvb As Object
    Set vbeobj = Application.VBE
    Set curDvb = vbeobj.ActiveVBProject
    menuName = VBA.Replace(VBA.dir(curDvb.FileName), ".dvb", vbNullString)
    Set mycmds = GetCurProjectSubNames("Mycmd_", menuName)
    Call AddMenuBarAndToolBar(mycmds, menuName, True, True)
    
    Dim cadVer As Double
    cadVer = VBA.CDbl(VBA.Left(Application.Version, 4))
    If cadVer > 17.1 Then                                      '2009版本开需要修改系统变量
        If ThisDrawing.GetVariable("MenuBar") = 0 Then ThisDrawing.SetVariable "MenuBar", 1
    End If
    Set vbeobj = Nothing: Set curDvb = Nothing
End Sub

利用代码导出需要的方法名称和宏，用于动态加载菜单

    '' <summary>
    ''' 提取方法名称
    ''' </summary>
    ''' <param name="serachTxt"></param>
    ''' <param name="curProjName"></param>
    ''' <returns></returns>
Public Function GetCurProjectSubNames(serachTxt As String, curProjName As String) As Dictionary
    Dim rtnDicts As New Dictionary, dicts As New Dictionary
    Dim VBComponent As Object, basModule As Object, curVBProject As Object, vbpro As Object, k As Long, i As Long
    '获取当前项目
    Set curVBProject = Application.VBE.ActiveVBProject
    If Not (curVBProject Is Nothing) Then
        For Each VBComponent In curVBProject.VBComponents
            If VBComponent.Type = 2 Or VBComponent.Type = 100 Then
                If VBComponent.CodeModule.Name = "ThisDrawing" Or VBComponent.CodeModule.Name = "ThisWorkBook" Then
                    Set basModule = VBComponent.CodeModule
                End If
            ElseIf VBComponent.Type = 1 Then
                Set basModule = VBComponent.CodeModule
            End If
            If Not (basModule Is Nothing) Then
                For i = 1 To basModule.CountOfLines
                    If basModule.ProcOfLine(i, vbext_pk_Proc) <> "" Then
                        Dim clsName As String, methodName As String
                        clsName = basModule.Name
                        methodName = basModule.ProcOfLine(i, vbext_pk_Proc)
                        If Not dicts.Exists(clsName & "." & methodName) And methodName Like serachTxt & "*" Then
                            rtnDicts(VBA.Replace(methodName, serachTxt, vbNullString)) _
                                    = Chr(3) & Chr(3) & Chr(95) & "-vbarun " & """" & clsName & "." & methodName & """" & Chr(32)
                            dicts.Add clsName & "." & methodName, ""
                        End If
                    End If
                Next i
            End If
        Next
    End If
    Set curVBProject = Nothing
    Set dicts = Nothing
    Set GetCurProjectSubNames = rtnDicts
End Function

创建菜单函数

 '@动态加载菜单栏
Public Sub AddMenuBarAndToolBar(ByRef cmds As Dictionary, MenuBarName As String, Optional LoadMenubar As Boolean = True, Optional LoadToolbar As Boolean = False)
    On Error Resume Next
    Dim mg  As AcadMenuGroup, mcount As Integer, popMenu As AcadPopupMenu, index As Long
    Dim varKey As Variant, i As Long
    mcount = Application.MenuGroups.Count
    For index = 0 To mcount - 1
        If Application.MenuGroups.Item(index).Name = "ACAD" Then Set mg = Application.MenuGroups.Item(index): Exit For
    Next
    '创建弹出菜单
    For index = mg.Menus.Count - 1 To 0 Step -1
        If mg.Menus.Item(index).Name = MenuBarName Then
            Set popMenu = mg.Menus.Item(index)
            Exit For
        End If
    Next
    If Not (popMenu Is Nothing) Then
        'mg.Menus.RemoveMenuFromMenuBar MenuBarName
    
        For i = popMenu.Count - 1 To 0 Step -1
            popMenu(i).Delete
        Next
        '插入命令
    
        For Each varKey In cmds.Keys()
            popMenu.AddMenuItem popMenu.Count + 1, varKey, cmds(varKey)
        Next
        If Not popMenu.OnMenuBar Then popMenu.InsertInMenuBar (MenuBarName)
    End If
    '
    If popMenu Is Nothing Then
        Set popMenu = mg.Menus.Add(MenuBarName)
        '提取全部的自定义命令
        For Each varKey In cmds.Keys()
            popMenu.AddMenuItem popMenu.Count + 1, varKey, cmds(varKey)
        Next
        popMenu.InsertInMenuBar (mg.Menus.Count + 1)
    End If
    
    '创建工具条
    Dim tb As AcadToolbar
    For index = mg.Toolbars.Count - 1 To 0 Step -1
        If mg.Toolbars.Item(index).Name = MenuBarName Then
            Set tb = mg.Toolbars.Item(index)
            Exit For
        End If
    Next
    If Not (tb Is Nothing) Then
        'mg.Menus.RemoveMenuFromMenuBar MenuBarName
    
        For i = tb.Count - 1 To 0 Step -1
            tb(i).Delete
        Next
        '插入命令
        For Each varKey In cmds.Keys()
            tb.AddToolbarButton tb.Count + 1, varKey, varKey, cmds(varKey)
        Next
        If Not tb.Visible = False Then tb.Visible = True
        tb.Dock acToolbarDockRight
    End If
    '
    If tb Is Nothing Then
        Set tb = mg.Toolbars.Add(MenuBarName)
        '提取全部的自定义命令
        For Each varKey In cmds.Keys()
            tb.AddToolbarButton tb.Count + 1, varKey, varKey, cmds(varKey)
        Next
        tb.Visible = True
        tb.Dock acToolbarDockRight
    End If
End Sub

将dvb的内部的代码保存问文本文件，截图如下

  ''' <summary>
    '''
    ''' </summary>
    ''' <param name="app">excel 或者 autocad的application对象</param>
    ''' <param name="vbafilefn">vba文件名称</param>
    ''' <param name="codeSavefdName">代码保存的文件夹</param>
Public Sub Mycmd_导出代码到文件()
    Dim VBComponent As Object, Count As Integer, dir As String, extension As String, curVBProject As Object, fso As New FileSystemObject, vbCompo As Object
    Set curVBProject = Application.VBE.ActiveVBProject
    dir = VBA.Replace(curVBProject.FileName, ".dvb", vbNullString) & "-代码备份文件\"
    If Not fso.FolderExists(dir) Then fso.CreateFolder dir
    For Each vbCompo In curVBProject.VBComponents
        Select Case vbCompo.Type
            Case 2, 100
                extension = ".cls"
            Case 3
                extension = ".frm"
            Case 1
                extension = ".bas"
            Case Else
                extension = ".txt"
        End Select
        On Error Resume Next
        Err.Clear
        Dim dirCode  As String
        dirCode = dir & "\" & vbCompo.Name & extension
        Call vbCompo.Export(dirCode)
        If Err.number <> 0 Then
            Call MsgBox("Failed to export " & vbCompo.Name & " to " & dirCode, vbCritical)
        Else
            Count = Count + 1
            'Debug.Print "Exported " & Left$(VBComponent.Name & ":" & Space(Padding), Padding) & path
        End If
    Next
    Set curVBProject = Nothing
End Sub

最后定义用于存储命令的自定义类型

 Public Type VbaCmd
    Name As String
    Macro As String
End Type

在模块的通用里面加入参数

Const vbext_pk_Get = 3
Const vbext_pk_Let = 1
Const vbext_pk_Proc = 0
Const vbext_pk_Set = 2

最终效果如图

=================

2022-05-15更新

部分网友觉得部署比较麻烦还得开cad软件

今天就利用vbs部署,新建一个文本文件，复制下面的代码到文本，另存为vbs格式，记得保存为ANSI编码格式，

将vbs文件复制到dvb文件所在的目录，双击vbs文件即完成部署工作

  
Dim curDvbFileName, fso, scrFn, curDirName,acApp,acadPath,curDir,wsh,curAcadVer
Set wsh = WScript.CreateObject("WScript.Shell")''IWshRuntimeLibrary;C:\Windows\SysWOW64\wshom.ocx
Set fso=WScript.CreateObject("Scripting.FileSystemObject")
'提取cad的安装路径
curAcadVer= Replace(wsh.RegRead("HKEY_CURRENT_USER\SOFTWARE\Autodesk\AutoCAD\CurVer"),"R",vbNullString)'读取cad最后启动的版本
Set acApp=WScript.CreateObject("AutoCAD.Application."& CInt(curAcadVer))
acadPath=acApp.Path
acApp.Quit'关闭cad软件
Set acApp=Nothing
'获取当前vbs所在的文件夹名称
curDirName=fso.GetFile(WScript.ScriptFullName).ParentFolder.Path
'MsgBox curDirName
Set curDir=fso.GetFolder(curDirName)
Dim fl
For Each fl In curDir.Files
    'MsgBox fl.Name & "," & fl.Path
    If StrComp(fso.GetExtensionName(fl.Path),"dvb",1)=0 Then 
        curDvbFileName=fl.path
        Exit For
    End If
Next
'提取dvb文件
If curDvbFileName<>vbNullString Then 
    'MsgBox curDvbFileName & acadpath
    '创建scr文件
    scrFn = Replace(curdvbfilename, ".dvb", ".scr")
    dvbName = Replace(fso.GetFileName(curdvbfilename), ".dvb", vbNullString)
    With fso.CreateTextFile(scrFn,True,False)
        .WriteLine  "filedia 0"
        .WriteLine  "cmdecho 0"
        .WriteLine  "_vbarun " & Chr(34) & Replace(curdvbfilename, "\", "/") & "!ThisDrawing.AddBar" & Chr(34)    'addbar表示需要随cad启动而执行的过程
        .WriteLine  "filedia 1" 
        .Close
    End With                          
    '创建桌面快捷方式
    Dim  lnkFilePath , shortCut
    lnkFilePath = wsh.SpecialFolders("Desktop") & "\" & Replace(fso.GetFileName(curdvbfilename), ".dvb", "(" & fso.GetFolder(acadPath).Name & ").lnk")    '创建快捷方式到桌面
    
    With wsh.CreateShortcut(lnkFilePath)
        .TargetPath = Chr(34) & acadPath &"\acad.exe" & Chr(34)
        .Arguments = "/nologo /b " & Chr(34) & scrFn & Chr(34)
        .WorkingDirectory = fso.GetParentFolderName(scrFn)
        .WindowStyle = 1                                       '//设置运行方式，默认为常规窗口                        '// '设置备注
        .Save
    End With
    wsh.Run "explorer.exe /select," & lnkFilePath,1
    MsgBox "安装成功！",vbInformation+vbOKOnly
Else
    MsgBox "安装失败!找不到dvb文件", vbAbort+ vbOKOnly
End If
Set fso= Nothing：Set wsh = Nothing

posted @ 2022-05-01 14:22 南胜NanSheng 阅读(1357) 评论(0) 编辑收藏举报

刷新页面返回顶部

登录后才能查看或发表评论，立即登录或者逛逛博客园首页

相关博文：

· C# AutoCAD为插件创建桌面和开始菜单启动方式

· AutoCAD Net 根据代码添加Menu Bar或者Tool Bar

· ARS展览项目（二）——环境搭建：opencv、dlib、VS2017

· cad自动加载dll

· vbs、cmd或bat常用语句，如创建快捷方式、添加到用户环境变量Path、开机启动等

阅读排行：
· winform 绘制太阳，地球，月球运作规律
· 超详细：普通电脑也行Windows部署deepseek R1训练数据并当服务器共享给他人
· TypeScript + Deepseek 打造卜卦网站：技术与玄学的结合
· AI 智能体引爆开源社区「GitHub 热点速览」
· 写一个简单的SQL生成工具

公告

昵称：南胜NanSheng
园龄： 5年9个月
粉丝： 81
关注： 9

+加关注

2025年3月

日

一

二

三

四

五

六

南胜NanSheng

研究AM船体，AutoCAD,SP3D,TEKLA, Excel等软件的二次开发项目

AutoCAD VBA部署方案分享

公告

搜索

常用链接

最新随笔

我的标签

积分与排名

随笔档案 (87)

阅读排行榜

评论排行榜

推荐排行榜

最新评论

	Public Sub Mycmd_创建DVB加载快捷方式()
	Dim curDvbName As String, fso As New FileSystemObject, scrFn As String, dvbName As String
	curDvbName = Application.VBE.ActiveVBProject.FileName
	'创建scr文件
	scrFn = VBA.Replace(curDvbName, ".dvb", ".scr")
	dvbName = VBA.Replace(fso.GetFileName(curDvbName), ".dvb", vbNullString)
	Open scrFn For Output As #1 '如改为For Append，则为追加文件。
	Print #1, "filedia 0"
	Print #1, "cmdecho 0"
	Print #1, "_vbarun " & Chr(34) & VBA.Replace(curDvbName, "\", "/") & "!ThisDrawing.AddBar" & Chr(34) 'addbar表示需要随cad启动而执行的过程
	Print #1, "filedia 1"
	Close #1

	'创建快捷方式
	Dim wsh As Object, lnkFilePath As String, shortCut As Object
	Set wsh = VBA.CreateObject("WScript.Shell") ''IWshRuntimeLibrary;C:\Windows\SysWOW64\wshom.ocx
	lnkFilePath = wsh.SpecialFolders("Desktop") & "\" & VBA.Replace(dir(curDvbName), ".dvb", "(" & fso.GetFolder(Application.Path).Name & ").lnk") '创建快捷方式到桌面
	'关于SpecialFolders 查看下面的网站即可查阅
	Rem https://www.vbsedit.com/html/7682257e-4042-4f7d-b266-03382021d0aa.asp
	'var startMenuDir = $@"C:\ProgramData\Microsoft\Windows\Start Menu\Programs";
	'"C:\Program Files (x86)\AutoCAD 2008\acad.exe" /nologo /b "C:\Users\NanSheng\AppData\Local\Temp\算法研究.scr"
	With wsh.CreateShortcut(lnkFilePath)
	.TargetPath = Chr(34) & Application.FullName & Chr(34)
	.Arguments = "/nologo /b " & Chr(34) & scrFn & Chr(34)
	.WorkingDirectory = fso.GetParentFolderName(scrFn)
	.WindowStyle = 1 '//设置运行方式，默认为常规窗口 '// '设置备注
	'//shortcut.IconLocation = String.IsNullOrWhiteSpace(iconLocation) ? targetPath : iconLocation;//设置图标路径
	.Save
	End With
	Set wsh = Nothing
	End Sub

	Public Sub AddBar()
	Dim mycmds As Dictionary, menuName As String, vbeobj As Object, curDvb As Object
	Set vbeobj = Application.VBE
	Set curDvb = vbeobj.ActiveVBProject
	menuName = VBA.Replace(VBA.dir(curDvb.FileName), ".dvb", vbNullString)
	Set mycmds = GetCurProjectSubNames("Mycmd_", menuName)
	Call AddMenuBarAndToolBar(mycmds, menuName, True, True)

	Dim cadVer As Double
	cadVer = VBA.CDbl(VBA.Left(Application.Version, 4))
	If cadVer > 17.1 Then '2009版本开需要修改系统变量
	If ThisDrawing.GetVariable("MenuBar") = 0 Then ThisDrawing.SetVariable "MenuBar", 1
	End If
	Set vbeobj = Nothing: Set curDvb = Nothing
	End Sub

	'' <summary>
	''' 提取方法名称
	''' </summary>
	''' <param name="serachTxt"></param>
	''' <param name="curProjName"></param>
	''' <returns></returns>
	Public Function GetCurProjectSubNames(serachTxt As String, curProjName As String) As Dictionary
	Dim rtnDicts As New Dictionary, dicts As New Dictionary
	Dim VBComponent As Object, basModule As Object, curVBProject As Object, vbpro As Object, k As Long, i As Long
	'获取当前项目
	Set curVBProject = Application.VBE.ActiveVBProject
	If Not (curVBProject Is Nothing) Then
	For Each VBComponent In curVBProject.VBComponents
	If VBComponent.Type = 2 Or VBComponent.Type = 100 Then
	If VBComponent.CodeModule.Name = "ThisDrawing" Or VBComponent.CodeModule.Name = "ThisWorkBook" Then
	Set basModule = VBComponent.CodeModule
	End If
	ElseIf VBComponent.Type = 1 Then
	Set basModule = VBComponent.CodeModule
	End If
	If Not (basModule Is Nothing) Then
	For i = 1 To basModule.CountOfLines
	If basModule.ProcOfLine(i, vbext_pk_Proc) <> "" Then
	Dim clsName As String, methodName As String
	clsName = basModule.Name
	methodName = basModule.ProcOfLine(i, vbext_pk_Proc)
	If Not dicts.Exists(clsName & "." & methodName) And methodName Like serachTxt & "*" Then
	rtnDicts(VBA.Replace(methodName, serachTxt, vbNullString)) _
	= Chr(3) & Chr(3) & Chr(95) & "-vbarun " & """" & clsName & "." & methodName & """" & Chr(32)
	dicts.Add clsName & "." & methodName, ""
	End If
	End If
	Next i
	End If
	Next
	End If
	Set curVBProject = Nothing
	Set dicts = Nothing
	Set GetCurProjectSubNames = rtnDicts
	End Function

	'@动态加载菜单栏
	Public Sub AddMenuBarAndToolBar(ByRef cmds As Dictionary, MenuBarName As String, Optional LoadMenubar As Boolean = True, Optional LoadToolbar As Boolean = False)
	On Error Resume Next
	Dim mg As AcadMenuGroup, mcount As Integer, popMenu As AcadPopupMenu, index As Long
	Dim varKey As Variant, i As Long
	mcount = Application.MenuGroups.Count
	For index = 0 To mcount - 1
	If Application.MenuGroups.Item(index).Name = "ACAD" Then Set mg = Application.MenuGroups.Item(index): Exit For
	Next
	'创建弹出菜单
	For index = mg.Menus.Count - 1 To 0 Step -1
	If mg.Menus.Item(index).Name = MenuBarName Then
	Set popMenu = mg.Menus.Item(index)
	Exit For
	End If
	Next
	If Not (popMenu Is Nothing) Then
	'mg.Menus.RemoveMenuFromMenuBar MenuBarName

	For i = popMenu.Count - 1 To 0 Step -1
	popMenu(i).Delete
	Next
	'插入命令

	For Each varKey In cmds.Keys()
	popMenu.AddMenuItem popMenu.Count + 1, varKey, cmds(varKey)
	Next
	If Not popMenu.OnMenuBar Then popMenu.InsertInMenuBar (MenuBarName)
	End If
	'
	If popMenu Is Nothing Then
	Set popMenu = mg.Menus.Add(MenuBarName)
	'提取全部的自定义命令
	For Each varKey In cmds.Keys()
	popMenu.AddMenuItem popMenu.Count + 1, varKey, cmds(varKey)
	Next
	popMenu.InsertInMenuBar (mg.Menus.Count + 1)
	End If

	'创建工具条
	Dim tb As AcadToolbar
	For index = mg.Toolbars.Count - 1 To 0 Step -1
	If mg.Toolbars.Item(index).Name = MenuBarName Then
	Set tb = mg.Toolbars.Item(index)
	Exit For
	End If
	Next
	If Not (tb Is Nothing) Then
	'mg.Menus.RemoveMenuFromMenuBar MenuBarName

	For i = tb.Count - 1 To 0 Step -1
	tb(i).Delete
	Next
	'插入命令
	For Each varKey In cmds.Keys()
	tb.AddToolbarButton tb.Count + 1, varKey, varKey, cmds(varKey)
	Next
	If Not tb.Visible = False Then tb.Visible = True
	tb.Dock acToolbarDockRight
	End If
	'
	If tb Is Nothing Then
	Set tb = mg.Toolbars.Add(MenuBarName)
	'提取全部的自定义命令
	For Each varKey In cmds.Keys()
	tb.AddToolbarButton tb.Count + 1, varKey, varKey, cmds(varKey)
	Next
	tb.Visible = True
	tb.Dock acToolbarDockRight
	End If
	End Sub

	''' <summary>
	'''
	''' </summary>
	''' <param name="app">excel 或者 autocad的application对象</param>
	''' <param name="vbafilefn">vba文件名称</param>
	''' <param name="codeSavefdName">代码保存的文件夹</param>
	Public Sub Mycmd_导出代码到文件()
	Dim VBComponent As Object, Count As Integer, dir As String, extension As String, curVBProject As Object, fso As New FileSystemObject, vbCompo As Object
	Set curVBProject = Application.VBE.ActiveVBProject
	dir = VBA.Replace(curVBProject.FileName, ".dvb", vbNullString) & "-代码备份文件\"
	If Not fso.FolderExists(dir) Then fso.CreateFolder dir
	For Each vbCompo In curVBProject.VBComponents
	Select Case vbCompo.Type
	Case 2, 100
	extension = ".cls"
	Case 3
	extension = ".frm"
	Case 1
	extension = ".bas"
	Case Else
	extension = ".txt"
	End Select
	On Error Resume Next
	Err.Clear
	Dim dirCode As String
	dirCode = dir & "\" & vbCompo.Name & extension
	Call vbCompo.Export(dirCode)
	If Err.number <> 0 Then
	Call MsgBox("Failed to export " & vbCompo.Name & " to " & dirCode, vbCritical)
	Else
	Count = Count + 1
	'Debug.Print "Exported " & Left$(VBComponent.Name & ":" & Space(Padding), Padding) & path
	End If
	Next
	Set curVBProject = Nothing
	End Sub


	Dim curDvbFileName, fso, scrFn, curDirName,acApp,acadPath,curDir,wsh,curAcadVer
	Set wsh = WScript.CreateObject("WScript.Shell")''IWshRuntimeLibrary;C:\Windows\SysWOW64\wshom.ocx
	Set fso=WScript.CreateObject("Scripting.FileSystemObject")
	'提取cad的安装路径
	curAcadVer= Replace(wsh.RegRead("HKEY_CURRENT_USER\SOFTWARE\Autodesk\AutoCAD\CurVer"),"R",vbNullString)'读取cad最后启动的版本
	Set acApp=WScript.CreateObject("AutoCAD.Application."& CInt(curAcadVer))
	acadPath=acApp.Path
	acApp.Quit'关闭cad软件
	Set acApp=Nothing
	'获取当前vbs所在的文件夹名称
	curDirName=fso.GetFile(WScript.ScriptFullName).ParentFolder.Path
	'MsgBox curDirName
	Set curDir=fso.GetFolder(curDirName)
	Dim fl
	For Each fl In curDir.Files
	'MsgBox fl.Name & "," & fl.Path
	If StrComp(fso.GetExtensionName(fl.Path),"dvb",1)=0 Then
	curDvbFileName=fl.path
	Exit For
	End If
	Next
	'提取dvb文件
	If curDvbFileName<>vbNullString Then
	'MsgBox curDvbFileName & acadpath
	'创建scr文件
	scrFn = Replace(curdvbfilename, ".dvb", ".scr")
	dvbName = Replace(fso.GetFileName(curdvbfilename), ".dvb", vbNullString)
	With fso.CreateTextFile(scrFn,True,False)
	.WriteLine "filedia 0"
	.WriteLine "cmdecho 0"
	.WriteLine "_vbarun " & Chr(34) & Replace(curdvbfilename, "\", "/") & "!ThisDrawing.AddBar" & Chr(34) 'addbar表示需要随cad启动而执行的过程
	.WriteLine "filedia 1"
	.Close
	End With
	'创建桌面快捷方式
	Dim lnkFilePath , shortCut
	lnkFilePath = wsh.SpecialFolders("Desktop") & "\" & Replace(fso.GetFileName(curdvbfilename), ".dvb", "(" & fso.GetFolder(acadPath).Name & ").lnk") '创建快捷方式到桌面

	With wsh.CreateShortcut(lnkFilePath)
	.TargetPath = Chr(34) & acadPath &"\acad.exe" & Chr(34)
	.Arguments = "/nologo /b " & Chr(34) & scrFn & Chr(34)
	.WorkingDirectory = fso.GetParentFolderName(scrFn)
	.WindowStyle = 1 '//设置运行方式，默认为常规窗口 '// '设置备注
	.Save
	End With
	wsh.Run "explorer.exe /select," & lnkFilePath,1
	MsgBox "安装成功！",vbInformation+vbOKOnly
	Else
	MsgBox "安装失败!找不到dvb文件", vbAbort+ vbOKOnly
	End If
	Set fso= Nothing：Set wsh = Nothing