VBA精彩代码分享-3

在开发VBA程序中，我们可能会需要用代码处理VBA工程，包括启用VBA工程访问，启用所有宏，动态插入代码，动态删除代码，动态添加引用和自动创建模块等等，本次的分享内容便以这些为主。

启用VBA工程访问

Dim oWshell As Object
Set oWshell = CreateObject("WScript.Shell")
oWshell.RegWrite "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & Application.Version & "ExcelSecurityAccessVBOM", 1, "REG_DWORD"
'将第二个参数改为0就是关闭

启用所有宏

Dim WScr As Object
Set WScr = CreateObject("WScript.Shell")
WScr.RegWrite "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & Application.Version & "ExcelSecurityVBAWarnings", "1", "REG_DWORD"
'将第二个参数改为0就是关闭

在工作表插入按钮并写入单击事件

Dim sCode, objBtn
With ActiveSheet
　For Each obj In .OLEObjects
  obj.Delete
  Next obj
  Set objBtn = .OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False, DisplayAsIcon:=False, Left:=120, Top:=50, Width:=130, Height:=30)
End With
sCode = "' *** Code Added By VBA ***" & vbCrLf & "Private Sub " & objBtn.Name & "_Click()" & vbCrLf & "  MsgBox ""Hello""" & vbCrLf & "End Sub" & vbCrLf
With ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule
  NextLine = .CountOfLines + 1
  .InsertLines NextLine, sCode
End With

删除某个过程

Dim CodeInd As Long
Dim sNo, eNo, bFlag
Const PROC_NAME = "PRIVATE SUB WORKSHEET_CHANGE(BYVAL TARGET AS RANGE)"
bFlag = False
With ThisWorkbook.VBProject.VBComponents("Sheet1").CodeModule
    For CodeInd = .CountOfDeclarationLines + 1 To .CountOfLines
        Select Case VBA.UCase$(Trim(.Lines(CodeInd, 1)))
            Case PROC_NAME
                bFlag = True
                sNo = CodeInd
            Case "END SUB"
                If bFlag Then
                    eNo = CodeInd
                    Exit For
                End If
        End Select
    Next CodeInd
    ' 逐行倒序删除
    'For i = eNo To sNo Step -1
    '    .DeleteLines i
    'Next
    ' 一次性删除整个过程代码
    .DeleteLines sNo, eNo - sNo + 1
End With

输出VBA工程的所有引用

On Error Resume Next
For n = 1 To ThisWorkbook.VBProject.References.Count
  Cells(n, 1) = ThisWorkbook.VBProject.References.Item(n).Name
  Cells(n, 2) = ThisWorkbook.VBProject.References.Item(n).Description
  Cells(n, 3) = ThisWorkbook.VBProject.References.Item(n).GUID
  Cells(n, 4) = ThisWorkbook.VBProject.References.Item(n).Major
  Cells(n, 5) = ThisWorkbook.VBProject.References.Item(n).Minor
  Cells(n, 6) = ThisWorkbook.VBProject.References.Item(n).fullpath
Next n

 删除VBA工程的所有引用

On Error Resume Next
Dim theRef As Variant
For I = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(I)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next I

添加VBA工程引用

Dim RefItem(6, 3) As Variant

RefItem(0, 0) = "{000204EF-0000-0000-C000-000000000046}"
RefItem(0, 1) = 4
RefItem(0, 2) = 2

RefItem(1, 0) = "{00020813-0000-0000-C000-000000000046}"
RefItem(1, 1) = 1
RefItem(1, 2) = 9

RefItem(2, 0) = "{00020430-0000-0000-C000-000000000046}"
RefItem(2, 1) = 2
RefItem(2, 2) = 0

RefItem(3, 0) = "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}"
RefItem(3, 1) = 2
RefItem(3, 2) = 8

RefItem(4, 0) = "{00000205-0000-0010-8000-00AA006D2EA4}"
RefItem(4, 1) = 2
RefItem(4, 2) = 5

RefItem(5, 0) = "{0D452EE1-E08F-101A-852E-02608C4D0BB4}"
RefItem(5, 1) = 2
RefItem(5, 2) = 0

On Error Resume Next
For I = 0 To 5
ThisWorkbook.VBProject.References.AddFromGuid GUID:=RefItem(I, 0), Major:=RefItem(I, 1), Minor:=RefItem(I, 2)
Select Case Err.Number
Case Is = 32813
'引用已经加载，无需做任何事情
Case Is = vbNullString
'成功加载
Case Else
'加载出现错误，保存错误信息
errmsg = errmsg & RefItem(I, 0) & "出现错误错误"
End Select
Next I
If errmsg <> "" Then
MsgBox errmsg
End If

创建模块并写入过程

Application.ScreenUpdating = False
For i = 1 To ThisWorkbook.VBProject.VBComponents.Count
If ThisWorkbook.VBProject.VBComponents(i).Name = "auto_code" Then
ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(i)
End If
Next
ThisWorkbook.VBProject.VBComponents.Add(1).Name = "auto_code"
ThisWorkbook.VBProject.VBComponents("auto_code").CodeModule.InsertLines 1, "Sub test()"
ThisWorkbook.VBProject.VBComponents("auto_code").CodeModule.InsertLines 2, "Msgbox""hello world!"""
ThisWorkbook.VBProject.VBComponents("auto_code").CodeModule.InsertLines 4, "end sub"
Application.OnTime Now + TimeValue("00:00:01"), "test"
Application.ScreenUpdating = True