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
