VBA精彩代码分享-1

今天下班前分享一下之前在网上搜到的两段好用的VBA代码，貌似都来自国外，觉得挺好，模仿不来。

第一段的功能是修改VBA控件中的文本框控件，使其右键可以选择粘贴、复制、剪切等：

Option Explicit

' Required API declarations
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

' Type required by TrackPopupMenu although this is ignored !!
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

' Type required by InsertMenuItem
Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type

' Type required by GetCursorPos
Private Type POINTAPI
        X As Long
        Y As Long
End Type

' Constants required by TrackPopupMenu
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_TOPALIGN = &H0
Private Const TPM_RETURNCMD = &H100
Private Const TPM_RIGHTBUTTON = &H2&

' Constants required by MENUITEMINFO type
Private Const MIIM_STATE = &H1
Private Const MIIM_ID = &H2
Private Const MIIM_TYPE = &H10
Private Const MFT_STRING = &H0
Private Const MFT_SEPARATOR = &H800
Private Const MFS_DEFAULT = &H1000
Private Const MFS_ENABLED = &H0
Private Const MFS_GRAYED = &H1

' Contants defined by me for menu item IDs
Private Const ID_Cut = 101
Private Const ID_Copy = 102
Private Const ID_Paste = 103
Private Const ID_Delete = 104
Private Const ID_SelectAll = 105


' Variables declared at module level
Private FormCaption As String
Private Cut_Enabled As Long
Private Copy_Enabled As Long
Private Paste_Enabled As Long
Private Delete_Enabled As Long
Private SelectAll_Enabled As Long



Public Sub ShowPopup(oForm As UserForm, strCaption As String, X As Single, Y As Single)

    Dim oControl As MSForms.TextBox
    Static click_flag As Long
    
    ' The following is required because the MouseDown event
    ' fires twice when right-clicked !!
    click_flag = click_flag + 1
        
    ' Do nothing on first firing of MouseDown event
    If (click_flag Mod 2 <> 0) Then Exit Sub
                
    ' Set object reference to the textboxthat was clicked
    Set oControl = oForm.ActiveControl
        
    ' If click is outside the textbox, do nothing
    If X > oControl.Width Or Y > oControl.Height Or X < 0 Or Y < 0 Then Exit Sub
    
    ' Retrieve caption of UserForm for use in FindWindow API
    FormCaption = strCaption
    
    ' Call routine that sets menu items as enabled/disabled
    Call EnableMenuItems(oForm)
    
    ' Call function that shows the menu and return the ID
    ' of the selected menu item. Subsequent action depends
    ' on the returned ID.
    Select Case GetSelection()
        Case ID_Cut
            oControl.Cut
        Case ID_Copy
            oControl.Copy
        Case ID_Paste
            oControl.Paste
        Case ID_Delete
            oControl.SelText = ""
        Case ID_SelectAll
            With oControl
                .SelStart = 0
                .SelLength = Len(oControl.Text)
            End With
    End Select

End Sub

Private Sub EnableMenuItems(oForm As UserForm)

    Dim oControl As MSForms.TextBox
    Dim oData As DataObject
    Dim testClipBoard As String
    
    On Error Resume Next
    
    ' Set object variable to clicked textbox
    Set oControl = oForm.ActiveControl
    
    ' Create DataObject to access the clipboard
    Set oData = New DataObject
    
    ' Enable Cut/Copy/Delete menu items if text selected
    ' in textbox
    If oControl.SelLength > 0 Then
        Cut_Enabled = MFS_ENABLED
        Copy_Enabled = MFS_ENABLED
        Delete_Enabled = MFS_ENABLED
    Else
        Cut_Enabled = MFS_GRAYED
        Copy_Enabled = MFS_GRAYED
        Delete_Enabled = MFS_GRAYED
    End If
    
    ' Enable SelectAll menu item if there is any text in textbox
    If Len(oControl.Text) > 0 Then
        SelectAll_Enabled = MFS_ENABLED
    Else
        SelectAll_Enabled = MFS_GRAYED
    End If
    
    ' Get data from clipbaord
    oData.GetFromClipboard
    
    ' Following line generates an error if there
    ' is no text in clipboard
    testClipBoard = oData.GetText

    ' If NO error (ie there is text in clipboard) then
    ' enable Paste menu item. Otherwise, diable it.
    If Err.Number = 0 Then
        Paste_Enabled = MFS_ENABLED
    Else
        Paste_Enabled = MFS_GRAYED
    End If
    
    ' Clear the error object
    Err.Clear
    
    ' Clean up object references
    Set oControl = Nothing
    Set oData = Nothing

End Sub

Private Function GetSelection() As Long

    Dim menu_hwnd As Long
    Dim form_hwnd As Long
    Dim oMenuItemInfo1 As MENUITEMINFO
    Dim oMenuItemInfo2 As MENUITEMINFO
    Dim oMenuItemInfo3 As MENUITEMINFO
    Dim oMenuItemInfo4 As MENUITEMINFO
    Dim oMenuItemInfo5 As MENUITEMINFO
    Dim oMenuItemInfo6 As MENUITEMINFO
    Dim oRect As RECT
    Dim oPointAPI As POINTAPI
    
    ' Find hwnd of UserForm - note different classname
    ' Word 97 vs Word2000
    #If VBA6 Then
        form_hwnd = FindWindow("ThunderDFrame", FormCaption)
    #Else
        form_hwnd = FindWindow("ThunderXFrame", FormCaption)
    #End If

    ' Get current cursor position
    ' Menu will be drawn at this location
    GetCursorPos oPointAPI
        
    ' Create new popup menu
    menu_hwnd = CreatePopupMenu
    
    ' Intitialize MenuItemInfo structures for the 6
    ' menu items to be added
    
    ' Cut
    With oMenuItemInfo1
            .cbSize = Len(oMenuItemInfo1)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fType = MFT_STRING
            .fState = Cut_Enabled
            .wID = ID_Cut
            .dwTypeData = "Cut"
            .cch = Len(.dwTypeData)
    End With
    
    ' Copy
    With oMenuItemInfo2
            .cbSize = Len(oMenuItemInfo2)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fType = MFT_STRING
            .fState = Copy_Enabled
            .wID = ID_Copy
            .dwTypeData = "Copy"
            .cch = Len(.dwTypeData)
    End With
    
    ' Paste
    With oMenuItemInfo3
            .cbSize = Len(oMenuItemInfo3)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fType = MFT_STRING
            .fState = Paste_Enabled
            .wID = ID_Paste
            .dwTypeData = "Paste"
            .cch = Len(.dwTypeData)
    End With
    
    ' Separator
    With oMenuItemInfo4
            .cbSize = Len(oMenuItemInfo4)
            .fMask = MIIM_TYPE
            .fType = MFT_SEPARATOR
    End With
    
    ' Delete
    With oMenuItemInfo5
            .cbSize = Len(oMenuItemInfo5)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fType = MFT_STRING
            .fState = Delete_Enabled
            .wID = ID_Delete
            .dwTypeData = "Delete"
            .cch = Len(.dwTypeData)
    End With
    
    ' SelectAll
    With oMenuItemInfo6
            .cbSize = Len(oMenuItemInfo6)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fType = MFT_STRING
            .fState = SelectAll_Enabled
            .wID = ID_SelectAll
            .dwTypeData = "Select All"
            .cch = Len(.dwTypeData)
    End With
    
    ' Add the 6 menu items
    InsertMenuItem menu_hwnd, 1, True, oMenuItemInfo1
    InsertMenuItem menu_hwnd, 2, True, oMenuItemInfo2
    InsertMenuItem menu_hwnd, 3, True, oMenuItemInfo3
    InsertMenuItem menu_hwnd, 4, True, oMenuItemInfo4
    InsertMenuItem menu_hwnd, 5, True, oMenuItemInfo5
    InsertMenuItem menu_hwnd, 6, True, oMenuItemInfo6
    
    ' Return the ID of the item selected by the user
    ' and set it the return value of the function
    GetSelection = TrackPopupMenu _
                    (menu_hwnd, _
                     TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, _
                     oPointAPI.X, oPointAPI.Y, _
                     0, form_hwnd, oRect)
        
    ' Destroy the menu
    DestroyMenu menu_hwnd

End Function

View Code

使用时复制进VBA工程中，再在窗体中新建一个文本框控件即可右击看到效果。

第二段的功能是破解EXCEL工作簿的所有密码，包括工作表保护密码，工作簿保护密码：

Public Sub AllInternalPasswords()
' Breaks worksheet and workbook structure passwords. Bob McCormick
' probably originator of base code algorithm modified for coverage
' of workbook structure / windows passwords and for multiple passwords
'
' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1)
' Modified 2003-Apr-04 by JEM: All msgs to constants, and
' eliminate one Exit Sub (Version 1.1.1)
' Reveals hashed passwords NOT original passwords
Const DBLSPACE As String = vbNewLine & vbNewLine
Const AUTHORS As String = DBLSPACE & vbNewLine & _
"Adapted from Bob McCormick base code by" & _
"Norman Harker and JE McGimpsey"
Const HEADER As String = "AllInternalPasswords User Message"
Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"
Const REPBACK As String = DBLSPACE & "Please report failure " & _
"to the microsoft.public.excel.programming newsgroup."
Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _
"now be free of all password protection, so make sure you:" & _
DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _
DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _
DBLSPACE & "Also, remember that the password was " & _
"put there for a reason. Don't stuff up crucial formulas " & _
"or data." & DBLSPACE & "Access and use of some data " & _
"may be an offense. If in doubt, don't."
Const MSGNOPWORDS1 As String = "There were no passwords on " & _
"sheets, or workbook structure or windows." & AUTHORS & VERSION
Const MSGNOPWORDS2 As String = "There was no protection to " & _
"workbook structure or windows." & DBLSPACE & _
"Proceeding to unprotect sheets." & AUTHORS & VERSION
Const MSGTAKETIME As String = "After pressing OK button this " & _
"will take some time." & DBLSPACE & "Amount of time " & _
"depends on how many different passwords, the " & _
"passwords, and your computer's specification." & DBLSPACE & _
"Just be patient! Make me a coffee!" & AUTHORS & VERSION
Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _
"Structure or Windows Password set." & DBLSPACE & _
"The password found was: " & DBLSPACE & "$$" & DBLSPACE & _
"Note it down for potential future use in other workbooks by " & _
"the same person who set this password." & DBLSPACE & _
"Now to check and clear other passwords." & AUTHORS & VERSION
Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _
"password set." & DBLSPACE & "The password found was: " & _
DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & _
"future use in other workbooks by same person who " & _
"set this password." & DBLSPACE & "Now to check and clear " & _
"other passwords." & AUTHORS & VERSION
Const MSGONLYONE As String = "Only structure / windows " & _
"protected with the password that was just found." & _
ALLCLEAR & AUTHORS & VERSION & REPBACK
Dim w1 As Worksheet, w2 As Worksheet
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
Dim PWord1 As String
Dim ShTag As Boolean, WinTag As Boolean

Application.ScreenUpdating = False
With ActiveWorkbook
WinTag = .ProtectStructure Or .ProtectWindows
End With
ShTag = False
For Each w1 In Worksheets
ShTag = ShTag Or w1.ProtectContents
Next w1
If Not ShTag And Not WinTag Then
MsgBox MSGNOPWORDS1, vbInformation, HEADER
Exit Sub
End If
MsgBox MSGTAKETIME, vbInformation, HEADER
If Not WinTag Then
MsgBox MSGNOPWORDS2, vbInformation, HEADER
Else
On Error Resume Next
Do 'dummy do loop
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
With ActiveWorkbook
.Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If .ProtectStructure = False And _
.ProtectWindows = False Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
MsgBox Application.Substitute(MSGPWORDFOUND1, _
"$$", PWord1), vbInformation, HEADER
Exit Do 'Bypass all for...nexts
End If
End With
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error GoTo 0
End If
If WinTag And Not ShTag Then
MsgBox MSGONLYONE, vbInformation, HEADER
Exit Sub
End If
On Error Resume Next
For Each w1 In Worksheets
'Attempt clearance with PWord1
w1.Unprotect PWord1
Next w1
On Error GoTo 0
ShTag = False
For Each w1 In Worksheets
'Checks for all clear ShTag triggered to 1 if not.
ShTag = ShTag Or w1.ProtectContents
Next w1
If ShTag Then
For Each w1 In Worksheets
With w1
If .ProtectContents Then
On Error Resume Next
Do 'Dummy do loop
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
.Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If Not .ProtectContents Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
MsgBox Application.Substitute(MSGPWORDFOUND2, _
"$$", PWord1), vbInformation, HEADER
'leverage finding Pword by trying on other sheets
For Each w2 In Worksheets
w2.Unprotect PWord1
Next w2
Exit Do 'Bypass all for...nexts
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error GoTo 0
End If
End With
Next w1
End If
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
End Sub

View Code

 使用时复制进要破解的EXCEL的VBA工程中，F5运行即可，可能会等待较长时间。