[讨论]剖析Power Utility Pak Version 6的保护方法

weist123

Power Utility Pak Version 6是一个著名VBA组合工具箱，主页：

http://spreadsheetpage.com/index.php/pupv6/home

附件可以查看源代码，其中有关注册保护部分的代码值得学习一下

8afdXn1K.rar (72.45 KB, 下载次数: 1716)

2008-10-24 13:13 上传

点击文件名下载附件
[讨论]解剖Power Utility Pak Version 6

[此贴子已经被作者于2008-10-24 13:14:31编辑过]

tfosorcim

作者的书《Excel.2003高级VBA编程宝典》是VBA入门的最佳教材，他也是Microsoft MVP 之一。

weist123

关键是看懂pub6.xla里面的代码，稍稍修改就成了完全版！

QUOTE:

Option Explicit
Option Private Module
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Private Declare Function HtmlHelp Lib "HHCtrl.ocx" Alias "HtmlHelpA" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Long) As Long
Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long
Declare Function RegCloseKey Lib "ADVAPI32.DLL" (ByVal hKey As Long) As Long
Declare Function RegSetValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByVal dwType As Long, ByVal sValue As String, ByVal dwSize As Long) As Long
Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long
Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByRef lValueType As Long, ByVal sValue As String, ByRef lResultLen As Long) As Long
Public Const PUPNAME As String = "Power Utility Pak"
Public Const MENUNAME As String = "&PUP v6"
Public Const SCMENUFILE As String = "shortcut menus.pup"
Public Const SCMENUITEM As Long = 11
Public Const BMFILE As String = "pup bookmarks.pup"
Public Const BMMENUITEM As Long = 12
Public Const LASTROW As Long = 83
Public LastUtility As String

Sub RunUtility()
Dim r As Long, FName As String, ProcName As String
Dim MenuSheet As Worksheet, UtilName As String
Dim ThisUtility As String
Set MenuSheet = ThisWorkbook.Sheets("Sheet1")
If phe() = True Then
MenuSheet.Range("A1") = ""
UserForm2.Show
Exit Sub
End If
r = CommandBars.ActionControl.Tag
With MenuSheet
FName = .Cells(r, 10)
ProcName = .Cells(r, 11)
UtilName = .Cells(r, 1)
On Error Resume Next
If Not BookOpen(FName) Then Workbooks.Open ThisWorkbook.Path & "\" & FName
If Err <> 0 Then
MsgBox UCase(FName) & vbCrLf & "File not found. This file should be located in" & ThisWorkbook.Path, vbCritical, PUPNAME
Exit Sub
End If
On Error GoTo 0
If .Cells(r, 9) = True And .Cells(r, 12) = "" Then .Cells(r, 12) = Application.Max(MenuSheet.Range("L:L")) + 1
Call CloseExcessUtilities
On Error Resume Next
ThisUtility = "'" & FName & "'!" & ProcName
If .Cells(r, 8) = True Then
LastUtility = ThisUtility
If GetSetting(PUPNAME, "Settings", "cbRememberLastUtility", 1) = 1 Then
Application.MacroOptions Macro:=ThisWorkbook.Name & "!RunLastUtility", HasShortcutKey:=True, ShortcutKey:="R"
Else
Application.MacroOptions Macro:=ThisWorkbook.Name & "!RunLastUtility", HasShortcutKey:=False, ShortcutKey:=""
End If
End If
' Run it
On Error Resume Next
Application.Run ThisUtility
On Error GoTo 0
End With
End Sub

Sub RunLastUtility()
On Error Resume Next
If GetSetting(PUPNAME, "Settings", "cbRememberLastUtility", 1) = 1 Then Application.Run LastUtility
On Error GoTo 0
End Sub

Sub MakeMenu()
Dim MenuSheet As Worksheet
Dim MenuPos As Long, r As Long
Dim UtilityMenu As CommandBarControl, Level1 As CommandBarControl, Level2 As CommandBarControl
Dim MenuBarIndex As Long

Set MenuSheet = ThisWorkbook.Sheets(1)
For MenuBarIndex = 1 To 2
On Error Resume Next
Application.CommandBars(MenuBarIndex).Controls(MENUNAME).Delete
MenuPos = 10
MenuPos = Application.CommandBars(MenuBarIndex).FindControl(ID:=30009).Index 'Window menu
On Error GoTo 0

Set UtilityMenu = Application.CommandBars(MenuBarIndex).Controls.Add(Type:=msoControlPopup, Before:=MenuPos, Temporary:=True)
UtilityMenu.Caption = MENUNAME
For r = 2 To LASTROW
If Not IsEmpty(MenuSheet.Cells(r, 2)) Then ' add menu item
If IsEmpty(MenuSheet.Cells(r, 3)) Then
Set Level1 = UtilityMenu.Controls.Add(Type:=msoControlButton, Temporary:=True)
With Level1
.OnAction = ThisWorkbook.Name & "!" & MenuSheet.Cells(r, 4)
.Tag = r
.Caption = MenuSheet.Cells(r, 2)
.FaceId = MenuSheet.Cells(r, 5)
End With
Else
Set Level1 = UtilityMenu.Controls.Add(Type:=msoControlPopup, Temporary:=True)
End If
Level1.Caption = MenuSheet.Cells(r, 2)
Level1.BeginGroup = MenuSheet.Cells(r, 2).Font.Bold
End If
If Level1.Type = msoControlPopup Then ' add submenu item?
Set Level2 = Level1.Controls.Add(Type:=msoControlButton, Temporary:=True)
With Level2
.OnAction = ThisWorkbook.Name & "!" & MenuSheet.Cells(r, 4)
.Tag = r
.Caption = MenuSheet.Cells(r, 3)
.FaceId = MenuSheet.Cells(r, 5)
.BeginGroup = MenuSheet.Cells(r, 3).Font.Bold
.Enabled = MenuSheet.Cells(r, 5 + MenuBarIndex)
End With
End If
Next r
With Application
If BookOpen(SCMENUFILE) Then .CommandBars(MenuBarIndex).Controls(MENUNAME).Controls(SCMENUITEM).State = msoButtonDown Else .CommandBars(MenuBarIndex).Controls(MENUNAME).Controls(SCMENUITEM).State = msoButtonUp
If BookOpen(BMFILE) Then .CommandBars(MenuBarIndex).Controls(MENUNAME).Controls(BMMENUITEM).State = msoButtonDown Else .CommandBars(MenuBarIndex).Controls(MENUNAME).Controls(BMMENUITEM).State = msoButtonUp
End With
Next MenuBarIndex
End Sub

Sub ToggleShortcuts()
Call ToggleUtility(SCMENUFILE, SCMENUITEM, "Shortcuts")
End Sub

Sub ToggleBookmarks()
Call ToggleUtility(BMFILE, BMMENUITEM, "Bookmarks")
End Sub

Sub ToggleUtility(MENUFILE, MENUITEM, Key)
Dim MenuBarIndex As Long
On Error Resume Next
With Application
If BookOpen(MENUFILE) Then
Workbooks(MENUFILE).Close
.CommandBars(1).Controls(MENUNAME).Controls(MENUITEM).State = msoButtonUp
.CommandBars(2).Controls(MENUNAME).Controls(MENUITEM).State = msoButtonUp
SaveSetting PUPNAME, "Settings", Key, 0
Else
On Error Resume Next
Workbooks.Open ThisWorkbook.Path & "\" & MENUFILE
If Err <> 0 Then
MsgBox "An error occured while attempting to open " & MENUFILE & vbCrLf & "The file should be located in" & ThisWorkbook.Path, vbCritical, PUPNAME
.CommandBars(1).Controls(MENUNAME).Controls(MENUITEM).State = msoButtonUp
.CommandBars(2).Controls(MENUNAME).Controls(MENUITEM).State = msoButtonUp
SaveSetting PUPNAME, "Settings", Key, 0
Else
.CommandBars(1).Controls(MENUNAME).Controls(MENUITEM).State = msoButtonDown
.CommandBars(2).Controls(MENUNAME).Controls(MENUITEM).State = msoButtonDown
SaveSetting PUPNAME, "Settings", Key, 1
End If
End If
End With
On Error GoTo 0
End Sub
Private Function BookOpen(FName) As Boolean
Dim x As Workbook
On Error Resume Next
Set x = Workbooks(FName)
If Err = 0 Then BookOpen = True Else BookOpen = False
On Error GoTo 0
End Function
Sub AboutBox()
FormAbout.Show
End Sub
Sub ResetLastCell()
Dim LastCell As Range, Msg As String
If ActiveWorkbook Is Nothing Then Exit Sub
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
ActiveSheet.UsedRange
Set LastCell = Cells(Range(Cells(1, 1), ActiveSheet.UsedRange).Rows.Count, Range(Cells(1, 1), ActiveSheet.UsedRange).Columns.Count)
Msg = "The 'last cell' is the cell at the intersection of the last row and last column that contains data or formatting." & vbCrLf & "To activate the last cell, press Ctrl+End." & vbCrLf & vbCrLf
Msg = Msg & "The last cell in " & ActiveSheet.Name & " has been reset to cell " & LastCell.Address(False, False) & "." & vbCrLf & vbCrLf & "Row " & LastCell.Row & " , Column " & LastCell.Column
MsgBox Msg, vbInformation, "Reset the Last Cell"
End Sub

Sub SynchSheets()
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Dim UserSheet As Worksheet, sht As Worksheet
Dim TopRow As Long, LeftCol As Long
Dim UserSel As String
Dim ShtCnt As Long
If ActiveWorkbook Is Nothing Then Exit Sub
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If ActiveWorkbook.Worksheets.Count = 1 Then
MsgBox "The activeworksheet contains only one worksheet.", vbInformation, "Synchronize Sheets"
Exit Sub
End If
Application.ScreenUpdating = False
Set UserSheet = ActiveSheet
TopRow = ActiveWindow.ScrollRow
LeftCol = ActiveWindow.ScrollColumn
UserSel = ActiveWindow.RangeSelection.Address
ShtCnt = 0
For Each sht In ActiveWorkbook.Worksheets
If sht.Visible Then 'skip hidden sheets
sht.Activate
Range(UserSel).Select
ActiveWindow.ScrollRow = TopRow
ActiveWindow.ScrollColumn = LeftCol
ShtCnt = ShtCnt + 1
End If
Next sht
UserSheet.Activate
Application.ScreenUpdating = True
MsgBox "Number of worksheets synchronized: " & ShtCnt, vbInformation, "Synchronize Sheets"
End Sub

Sub CloseExcessUtilities()
Dim ConfigSheet As Worksheet
Dim MaxUtils As Long
Dim UtilsOpen As Long
Dim ExcessUtils As Long
Dim OpenSeq As Variant
Dim r As Long

Set ConfigSheet = ThisWorkbook.Sheets(1)
MaxUtils = GetSetting(PUPNAME, "Settings", "MaxUtils", 3) + 1
If MaxUtils > 12 Then Exit Sub
UtilsOpen = Application.CountA(ConfigSheet.Range("L:L")) - 1
If UtilsOpen > MaxUtils Then
ExcessUtils = UtilsOpen - MaxUtils
For r = 2 To LASTROW
OpenSeq = ConfigSheet.Cells(r, 12)
If OpenSeq <> "" Then
On Error Resume Next
If OpenSeq <= ExcessUtils Then
Workbooks(ConfigSheet.Cells(r, 10).Text).Close
ConfigSheet.Cells(r, 12) = ""
Else
ConfigSheet.Cells(r, 12) = OpenSeq - ExcessUtils
End If
On Error GoTo 0
End If
Next r
End If
End Sub
Sub CallMakeMenu()
MakeMenu
MsgBox "The PUP v6 menu has been restored.", vbInformation, PUPNAME
End Sub

Sub ShowPUPHelp(Topic As Long)
Dim Result
Result = HtmlHelp(0, ThisWorkbook.Path & "\pup6.chm", &HF, ByVal Topic)
If Result = 0 Then MsgBox "Cannot display PUP v6 Help - Topic " & Topic, vbCritical, PUPNAME
End Sub

Sub ShowHelp()
ShowPUPHelp 800
End Sub

Sub PUPAlarm1()
On Error Resume Next
AppActivate "Microsoft Excel"
Call PlaySound(ThisWorkbook.Path & "\alarm.wav", 0&, &H1 Or &H20000)
Application.Caption = Empty
MsgBox "This is your reminder message." & vbCrLf & vbCrLf & "It's now " & Format(Now, "Medium Time"), vbInformation, "PUP v6 Reminder Alarm"
On Error GoTo 0
End Sub

Sub PUPAlarm2()
On Error Resume Next
AppActivate "Microsoft Excel"
Call PlaySound(ThisWorkbook.Path & "\alarm.wav", 0&, &H1 Or &H20000)
Application.Caption = Empty
On Error GoTo 0
End Sub

Sub PUPAlarm3()
On Error Resume Next
AppActivate "Microsoft Excel"
Application.Caption = Empty
MsgBox "This is your reminder message." & vbCrLf & vbCrLf & "It's now " & Format(Now, "Medium Time"), vbInformation, "PUP v6 Reminder Alarm"
On Error GoTo 0
End Sub

Sub OpenFontSheet()
On Error Resume Next
Workbooks.Open Filename:=ThisWorkbook.Path & "\font reference.xlt", editable:=False
If Err.Number <> 0 Then
MsgBox "The 'font reference.template' file is missing or cannot be opened.", vbCritical, PUPNAME
Exit Sub
End If
On Error GoTo 0
End Sub

Function con(s)
Dim st As String, i As Integer
st = ""
For i = 1 To 67
st = st & Chr(Asc(Mid(s, i, 1)) - 1)
Next i
con = st
End Function

Function phe() As Variant
Dim RV As String, dl As Long
Const RK As String = "HKEY_CURRENT_USER"
Dim P As String
P = con("Tpguxbsf]Njdsptpgu]Sfhdmbtt]|G[R64C71.F8G1.323V.9599.115B224H87H:~]")
RV = GetRegistry(RK, P, "Cache")
Select Case RV
Case "1.00"
phe = True
Case "Not Found"
RV = "502" & Format(DateValue(Now), "00000") & "35836912"
WriteRegistry RK, P, "Cache", RV
phe = 30
Case Else
dl = CLng(30 - (DateValue(Now) - CLng(Mid(RV, 4, 5))))
If dl < 1 Then
WriteRegistry RK, P, "Cache", "1.00"
phe = True
Else
phe = dl
End If
End Select
End Function

Function GetRegistry(Key, Path, ByVal ValueName As String)
Dim hKey As Long, lValueType As Long, sResult As String, lResultLen As Long, ResultLen As Long, x, TheKey As Long
TheKey = &H80000001
If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then x = RegCreateKeyA(TheKey, Path, hKey)
sResult = Space(100)
lResultLen = 100
x = RegQueryValueExA(hKey, ValueName, 0, lValueType, sResult, lResultLen)
If x = 0 Then GetRegistry = Left(sResult, lResultLen - 1) Else GetRegistry = "Not Found"
RegCloseKey hKey
End Function

Function WriteRegistry(ByVal Key As String, ByVal Path As String, ByVal entry As String, ByVal value As String)
Dim hKey As Long, lValueType As Long, sResult As String, lResultLen As Long, TheKey, x
TheKey = &H80000001
If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then x = RegCreateKeyA(TheKey, Path, hKey)
x = RegSetValueExA(hKey, entry, 0, 1, value, Len(value) + 1)
WriteRegistry = (x = 0)
End Function

UserForm2显示的就是，30天试用期已满！

[此贴子已经被作者于2008-10-23 11:16:03编辑过]

weist123

这种加密方法居然没人敢兴趣？

lovbase

感是感兴趣，就是看不懂！

weist123

很简单啊，就是宏启动时往注册表里写入一个值，以后每次都检查，到0了就加载不了这个宏了。

金融风暴

楼主能否说具体一些, 如何破解!

2164526

看源码，谢谢！

[ 本帖最后由 2164526 于 2008-12-2 09:35 编辑 ]

ykyloveu

我的McAfee查到以上的附件有病毒。。。

Marmen

能否分享一下具体步骤 怎么都搞不定的 郁闷