• Welcome to the world's largest Chinese hacker forum

    Welcome to the world's largest Chinese hacker forum, our forum registration is open! You can now register for technical communication with us, this is a free and open to the world of the BBS, we founded the purpose for the study of network security, please don't release business of black/grey, or on the BBS posts, to seek help hacker if violations, we will permanently frozen your IP and account, thank you for your cooperation. Hacker attack and defense cracking or network Security

    business please click here: Creation Security  From CNHACKTEAM

Recommended Posts

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

1'通过代码编写可控硅整流器(可控硅整流器)文件和创建二乙烯基苯工程加载快捷方式

C: \程序文件(x86)\ AutoCAD 2008 \ acad。exe '/no徽标/b ' d : \ VB项目\算法研究' scr '

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

/b表示需要启动无赖的时候,加载二进制程序

具体参考官方说明

https://知识。欧特克。com/zh-Hans/support/AutoCAD/learn-explore/caas/cloud help/cloud help/2018/CHS/AutoCAD-Core/files/GUID-8e 54 b 6 EC-5b 52-4f 62-B7FC-0 D4 E1 EDF 093 a-htm超文本标记语言

r5nrutvyml13306.png

2.scr文件的内部如下

pdzbuk5i54v3307.png

创建快捷方式

公共潜水艇创建二乙烯基苯加载快捷方式()

Dim mycmds为变体,菜单名称为字符串,curDvbName为字符串,fso为新文件系统对象为线

curDvbName=应用程序. VBE。ActiveVBProject.FileName

'创建可控硅整流器(可控硅整流器)文件

VBA .替换(curDvbName,' .dvb ',' .SCR’)

文件目录0

cmdecho 0

(vl-vbaload 'D:/VBProject/算法研究. dvb’)

(vl-vbarun 'AddBar ')

档案一

打开输出为#1的scrFn如改为对于追加,则为追加文件。

打印#1,' filedia 0 '

打印#1,' cmdecho 0 '

打印排名第一的是VBA .替换(curDvbName,' \ ','/') Chr(34)')'

打印#1,'(VL-vbarun ' Chr(34)' AddBar ' Chr(34)')'添加栏表示需要随无赖启动而执行的过程

打印排名第一的“filedia 1”

打印#1,vbNullString

关闭#1

'创建快捷方式

Dim wsh作为对象,lnkFilePath作为字符串,快捷方式作为对象

设置VBA .CreateObject('WScript .shell”)“IWshRuntimeLibrary;c : \ Windows \ sys wow 64 \ w shom。定制控件

lnkFilePath=wsh .特殊文件夹("桌面”)“\ VBA .替换(dir(curDvbName),' .' dvb ',' dvb '' lnk ')'创建快捷方式到桌面

var startMenuDir=$ @ ' c : \ program data \ Microsoft \ Windows \开始菜单\程序;

lnkFilePath=' c : \ program data \ Microsoft \ Windows \开始菜单\程序\' VBA .替换(dir(curDvbName),' .' dvb ',' dvb '' lnk ')'创建快捷方式到开始菜单

lnkFilePath=VBA .替换(scrFn,' 1 .scr ',' .lnk’)

c : \程序文件(x86)\ AutoCAD 2008 \ acad。c : \ Users \ nan sheng \ AppData \ Local \ Temp \算法研究' scr '

设置快捷方式=wsh .创建快捷方式(lnkFilePath)

shortCut.TargetPath = Chr(34) & Application.FullName & Chr(34) shortCut.Arguments = "/nologo /b " & Chr(34) & scrFn & Chr(34) shortCut.WorkingDirectory = fso.GetParentFolderName(scrFn) shortCut.WindowStyle = 1 '//设置运行方式,默认为常规窗口 '// '设置备注 '//shortcut.IconLocation = String.IsNullOrWhiteSpace(iconLocation) ? targetPath : iconLocation;//设置图标路径 shortCut.Save Set wsh = Nothing End Sub

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

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

Public Sub AddBar()
    Dim mycmds As Variant, 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)
    mycmds = GetCurProjectSubNames("Mycmd_", menuName)
    Call AddMenuBarFunction(mycmds, menuName)
    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 MyVbaCmd()
    Dim CMDS() As MyVbaCmd, res As New Dictionary
    Dim VBComponent As Object, basModule As CodeModule, curVBProject As VBProject, 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_ProcKind.vbext_pk_Proc) <> "" Then
                        Dim clsName As String, methodName As String
                        clsName = basModule.Name
                        methodName = basModule.ProcOfLine(i, vbext_ProcKind.vbext_pk_Proc)
                        If Not res.Exists(clsName & "." & methodName) And methodName Like serachTxt & "*" Then
                            ReDim Preserve CMDS(0 To k)
                            Dim cmd As New MyVbaCmd
                            With cmd
                                .Name = VBA.Replace(methodName, serachTxt, vbNullString)
                                .Macro = Chr(3) & Chr(3) & Chr(95) & "-vbarun " & """" & clsName & "." & methodName & """" & Chr(32)
                            End With
                            Set CMDS(k) = cmd
                            res.Add clsName & "." & methodName, ""
                            k = k + 1
                            Set cmd = Nothing
                        End If
                    End If
                Next i
            End If
        Next
    End If
    GetCurProjectSubNames = CMDS
End Function

创建菜单函数

Public Function AddMenuBarFunction(ByRef CMDS As Variant, MenuBarName As String)
    On Error Resume Next
    'If ThisDrawing.GetVariable("MenuBar") = 0 Then ThisDrawing.SetVariable "MenuBar", 1
    Dim mg  As AcadMenuGroup, mcount As Integer, popMenu As AcadPopupMenu, index 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
        Dim i As Long
        For i = popMenu.Count - 1 To 0 Step -1
            popMenu(i).Delete
        Next
        For index = LBound(CMDS) To UBound(CMDS)
            popMenu.AddMenuItem popMenu.Count + 1, CMDS(index).Name, CMDS(index).Macro
        Next
        If Not popMenu.OnMenuBar Then popMenu.InsertInMenuBar (MenuBarName)
    End If
    '
    If popMenu Is Nothing Then
        Set popMenu = mg.Menus.Add(MenuBarName)
        '提取全部的自定义命令
        For index = LBound(CMDS) To UBound(CMDS)
            popMenu.AddMenuItem popMenu.Count + 1, CMDS(index).Name, CMDS(index).Macro
        Next
        popMenu.InsertInMenuBar (mg.Menus.Count + 1)
    End If
End Function

将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
    Dim vbeobj As Object, vbCompo As Object
    Set vbeobj = Application.VBE
    Set curVBProject = vbeobj.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
End Sub

最后类模块用于存储命令的信息

cskbqsa0k1r3308.png

nlrma1rntsn3309.png

0ylqokmurbn3310.png

源代码下载

https://files.cnblogs.com/files/NanShengBlogs/%E7%AE%97%E6%B3%95%E7%A0%94%E7%A9%B6-%E4%BB%A3%E7%A0%81%E5%A4%87%E4%BB%BD%E6%96%87%E4%BB%B6.zip?t=1651386037

Link to comment
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now