VBA精彩代码分享-3

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

启用VBA工程访问

Dim oWshell As Object
Set oWshell = CreateObject("WScript.Shell")
oWshell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM", , "REG_DWORD"
'将第二个参数改为0就是关闭

启用所有宏

Dim WScr As Object
Set WScr = CreateObject("WScript.Shell")
WScr.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\VBAWarnings", "", "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:=, Top:=, Width:=, Height:=)
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 +
  .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 +  To .CountOfLines
        Select Case VBA.UCase$(Trim(.Lines(CodeInd, )))
            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 +
End With

输出VBA工程的所有引用

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

 删除VBA工程的所有引用

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

添加VBA工程引用

Dim RefItem(, ) As Variant
 
RefItem(, ) = "{000204EF-0000-0000-C000-000000000046}"
RefItem(, ) =
RefItem(, ) = 
 
RefItem(, ) = "{00020813-0000-0000-C000-000000000046}"
RefItem(, ) =
RefItem(, ) = 
 
RefItem(, ) = "{00020430-0000-0000-C000-000000000046}"
RefItem(, ) =
RefItem(, ) = 
 
RefItem(, ) = "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}"
RefItem(, ) =
RefItem(, ) = 
 
RefItem(, ) = "{00000205-0000-0010-8000-00AA006D2EA4}"
RefItem(, ) =
RefItem(, ) = 
 
RefItem(, ) = "{0D452EE1-E08F-101A-852E-02608C4D0BB4}"
RefItem(, ) =
RefItem(, ) = 
 
On Error Resume Next
For I =  To
ThisWorkbook.VBProject.References.AddFromGuid GUID:=RefItem(I, ), Major:=RefItem(I, ), Minor:=RefItem(I, )
Select Case Err.Number
Case Is =
'引用已经加载，无需做任何事情
Case Is = vbNullString
'成功加载
Case Else
'加载出现错误，保存错误信息
errmsg = errmsg & RefItem(I, ) & "出现错误错误"
End Select
Next I
If errmsg <> "" Then
MsgBox errmsg
End If

创建模块并写入过程

Application.ScreenUpdating = False
For i =  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().Name = "auto_code"
ThisWorkbook.VBProject.VBComponents("auto_code").CodeModule.InsertLines , "Sub test()"
ThisWorkbook.VBProject.VBComponents("auto_code").CodeModule.InsertLines , "Msgbox""hello world!"""
ThisWorkbook.VBProject.VBComponents("auto_code").CodeModule.InsertLines , "end sub"
Application.OnTime Now + TimeValue("00:00:01"), "test"
Application.ScreenUpdating = True