VBA学习笔记（一）：自动添加代码&VBA修改注册表

一、以下代码是通过Auto_Open事件，自动向ThisWorkbook里添加VBA代码：

Private Sub Auto_Open()
  Call AddCodeToThisWorkbook
  MsgBox ("This is Auto_Open Sub !")
End Sub

Private Sub AddCodeToThisWorkbook()  
    With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
        .InsertLines 1, "Private Sub Workbook_open()"
        .InsertLines 2, "   MsgBox (""This is Workbook_Open Sub !"")"
        .InsertLines 3, "End Sub"
    End With
End Sub

二、以下代码是通过VBA修改注册表： 

Sub ChangeSettings()
    Dim Fso
    Dim RegKey_User_AcsVm As String
    Dim RegKey_User_Level As String
    Dim RegKey_Mach_AcsVm As String
    Dim RegKey_Mach_Level As String
    Dim RegVal_User_AcsVm As Variant
    Dim RegVal_User_Level As Variant
    Dim RegVal_Mach_AcsVm As Variant
    Dim RegVal_Mach_Level As Variant
    Dim ExcelVersion As String
    
    On Error Resume Next
    
    ExcelVersion = Application.Version
    Set Fso = CreateObject("Scripting.FileSystemObject")
    
    RegKey_User_AcsVm = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & ExcelVersion & "\Excel\Security\AccessVBOM"
    RegKey_User_Level = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & ExcelVersion & "\Excel\Security\Level"
    RegKey_Mach_AcsVm = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & ExcelVersion & "\Excel\Security\AccessVBOM"
    RegKey_Mach_Level = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & ExcelVersion & "\Excel\Security\Level"
    
    Value_User_AcsVm = 1
    Value_User_Level = 1
    Value_Mach_AcsVm = 1
    Value_Mach_Level = 1

    Call ModReg(RegKey_User_AcsVm, Value_User_AcsVm, "REG_DWORD")
    Call ModReg(RegKey_User_Level, Value_User_Level, "REG_DWORD")
    Call ModReg(RegKey_Mach_AcsVm, Value_Mach_AcsVm, "REG_DWORD")
    Call ModReg(RegKey_Mach_Level, Value_Mach_Level, "REG_DWORD")

End Sub

Sub ModReg(RegKey As String, Value As Variant, ValueType As String)
    Dim oWshell
    Set oWshell = CreateObject("WScript.Shell")
    If ValueType = "" Then
        oWshell.RegWrite RegKey, Value
    Else
        oWshell.RegWrite RegKey, Value, ValueType
    End If
    Set oWshell = Nothing
End Sub

 三、以下函数用来判断一个工作簿中是否存在指定的Sheet名： 

Function SheetIsExist(WBookName As String,WSheetName As String) As Boolean    
    Dim Tmp_WSheet As Worksheet    
    For Each Tmp_WSheet In Workbooks(WBookName).Worksheets    
        If UCase(Tmp_WSheet.Name) = UCase(WSheetName) Then
            SheetIsExist = True
            Exit Function
        End If                     
    Next Tmp_WSheet    
    SheetIsExist = False       
End Function

  以下为调用SheetIsExist函数的示例： 

Sub Example01()
    '开始计时
    begin = Timer
    '禁止刷屏
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '记录当前文件名
    Dim CurFileName As String
    CurFileName = Sheets("Sheet1").[A1].Parent.Parent.Name

    If SheetIsExist(CurFileName, "Sheet2") Then
        Worksheets("Sheet2").Delete
    End If
    If SheetIsExist(CurFileName, "Sheet3") Then
        Worksheets("Sheet3").Delete
    End If
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    over = Timer

    MsgBox ("已运行完成！共运行" & over - begin & "s")

End Sub