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

frankfurt200

楼主能把那附件发到小弟邮箱里吗? 这网站说俺无权浏览那附件。

另外您的意思是不是就是把那原始的xla换成你那修改后的xla， 就可以无限期使用了？

多谢了！  别的已下载的大侠们，若有空给俺转发一下那附件，同谢啦！

Frankfurt2008@hotmail.com

hlyhuagong

楼主，为什么那个power utility pak v7下载不了呢，楼主能不能帮忙发一份到邮箱，万分感谢，另外楼主发的那个附件好像也下不了
新手邮箱：liangyong_he@163.com

wei001

???????????

mgw2314

之前也看过Power Utility Pak的源代码，但看不懂！~！！
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

mgw2314

怎么破解不了啊！
打开VBA有密码啊！

andysky

weist123 发表于 2008-10-24 13:12
这种加密方法居然没人敢兴趣？

因为没有用

liucqa

呵呵，我刚看了pup7的代码，30天检查就是在注册表写上第一次使用的日期，然后检查而已。代码挺花哨，破解很容易。

里面的con()函数思路不错，挺好玩的

geek1978

weist123 发表于 2008-10-23 11:12
关键是看懂pub6.xla里面的代码，稍稍修改就成了完全版！QUOTE:Option ExplicitOption Private ModulePrivat ...

Wow！牛人啊

中年

这个东西汉化后对学VBA很有帮助?