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