今天下班前分享一下之前在网上搜到的两段好用的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 =
Private Const ID_Copy =
Private Const ID_Paste =
Private Const ID_Delete =
Private Const ID_SelectAll = ' 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 + ' Do nothing on first firing of MouseDown event
If (click_flag Mod <> ) 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 < Or Y < 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 =
.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 > 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) > 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 = 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, , True, oMenuItemInfo1
InsertMenuItem menu_hwnd, , True, oMenuItemInfo2
InsertMenuItem menu_hwnd, , True, oMenuItemInfo3
InsertMenuItem menu_hwnd, , True, oMenuItemInfo4
InsertMenuItem menu_hwnd, , True, oMenuItemInfo5
InsertMenuItem menu_hwnd, , 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, _
, form_hwnd, oRect) ' Destroy the menu
DestroyMenu menu_hwnd End Function
使用时复制进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 = To : For j = To : For k = To
For l = To : For m = To : For i1 = To
For i2 = To : For i3 = To : For i4 = To
For i5 = To : For i6 = To : For n = To
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
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
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 = To : For j = To : For k = To
For l = To : For m = To : For i1 = To
For i2 = To : For i3 = To : For i4 = To
For i5 = To : For i6 = To : For n = To
.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
End If
End With
Next w1
End If
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
End Sub
使用时复制进要破解的EXCEL的VBA工程中，F5运行即可，可能会等待较长时间。
如果需要破解VBA工程密码，需要将xlsm文件另存为xls文件，具体参考以下链接