zoukankan      html  css  js  c++  java
  • 20170719xlVbaAbsorbProcedure

    Sub AbsorbThisProcedure()
    
        If Application.VBE.MainWindow.Visible = False Then
            MsgBox "请先激活VBE编辑窗口再执行!"
            Exit Sub
        End If
    
        On Error Resume Next
        Set VbCodePane = Application.VBE.ActiveCodePane    '获取当前代码窗口
        If Err.Number = 1004 Then
            MsgBox "请勾选“信任对VBA工程对象模型的访问”"
            Exit Sub
        Else
            If Err.Number <> 0 Then
                Exit Sub
            End If
        End If
        On Error GoTo 0
    
    
        Dim CodeMod As CodeModule
        Dim CodeContent As String
        Dim CurCodePane As Object
        Dim ProcName As String
        Dim LineCount As Long
        'Dim OneAddIn As AddIn
        Dim Wb As Workbook
        Dim Sht As Worksheet
        Dim Rng As Range
        Dim FindRng As Range
        Dim StartLine&, EndLine&, StartCol&, EndCol&
    
    
        Set CurCodePane = ActiveWorkbook.VBProject.VBE.ActiveCodePane
        CurCodePane.GetSelection StartLine, StartCol, EndLine, EndCol
    
        ProcName = ActiveWorkbook.VBProject.VBE.SelectedVBComponent.CodeModule.ProcOfLine(StartLine, vbext_pk_Proc)
    
        Debug.Print ProcName
    
        StartLine = ActiveWorkbook.VBProject.VBE.SelectedVBComponent.CodeModule.ProcStartLine(ProcName, vbext_pk_Proc)
        LineCount = ActiveWorkbook.VBProject.VBE.SelectedVBComponent.CodeModule.ProcCountLines(ProcName, vbext_pk_Proc)
    
        Set CodeMod = Application.VBE.ActiveCodePane.CodeModule
        CodeContent = CodeMod.Lines(StartLine, LineCount)
    
        Debug.Print CodeContent
    
        If Len(CodeContent) = 0 Then Exit Sub
    
        msg = MsgBox("是否确定添加本过程到加载宏?按是继续执行!按否退出执行!", vbYesNo)
        If msg = vbNo Then Exit Sub
    
        Set Wb = ThisWorkbook
        Set Sht = Wb.Worksheets("CodeData")
        With Sht
    
            EndRow = .Range("B65536").End(xlUp).Row
            Set Rng = .Range("B1:B" & EndRow)
            Set FindRng = Rng.Find(What:=ProcName, LookAt:=xlWhole)
    
            If FindRng Is Nothing Then
                Set Rng = .Range("B65536").End(xlUp).Offset(1)
                Rng.Value = ProcName
                Rng.Offset(0, 1).Value = CodeContent
    
            Else
                msg = MsgBox("模块名称已经存在,是否覆盖模块代码?", vbYesNo, "Tips")
                If msg = vbNo Then
                    GoTo FreeObject
                Else
                    FindRng.Offset(0, 1).Value = CodeContent
                End If
            End If
    
        End With
    
        Call AddMenu
    
        Wb.Save
    FreeObject:
        Set CodeMod = Nothing
        Set Wb = Nothing
        Set Rng = Nothing
        Set FindRng = Nothing
    
    
    End Sub
    

      

  • 相关阅读:
    HDU 4118:Holiday's Accommodation 简单树形DP(2011 Asia ChengDu Regional Contest )
    HDU 4276:The Ghost Blows Light 树形DP(2012 ACM/ICPC Asia Regional Changchun Online )
    HDU 3586:Information Disturbing 树形DP+二分
    HDU 4044:GeoDefense 树形DP+分组背包
    HDU 4003:Find Metal Mineral 树形DP+分组背包
    HDU 2196:Computer 树形DP
    Codeforces 681D:Gifts by the List (dfs+topsort)
    Codeforces 681C:Heap Operations
    跨浏览器注册事件和移除事件方案
    jquery 清空表达内容
  • 原文地址:https://www.cnblogs.com/nextseven/p/7205415.html
Copyright © 2011-2022 走看看