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
    

      

  • 相关阅读:
    openSUSE字体美化
    [转摘]关于创建oracle dblink 过程的几点心得
    IList及泛型集合类转换DataTable
    C# 编码规范和编程好习惯
    随机数和随机字符串
    ThrowActivity 光阴的故事
    数据库的数据 转化为XML 在页面上浏览 光阴的故事
    EventHandlingScopeActivity 光阴的故事
    workflow 角色的使用关键 光阴的故事
    ConditionedActivityGroup 光阴的故事
  • 原文地址:https://www.cnblogs.com/nextseven/p/7205415.html
Copyright © 2011-2022 走看看