ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 20993|回复: 47

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

 关闭 [复制链接]

TA的精华主题

TA的得分主题

发表于 2008-10-23 10:30 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:保护和加密编程
本帖最后由 chrisfang 于 2014-2-15 15:23 编辑

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

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


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

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

点评

知识树索引内容:位于3楼  发表于 2014-2-15 15:22

TA的精华主题

TA的得分主题

发表于 2008-10-23 10:37 | 显示全部楼层
作者的书《Excel.2003高级VBA编程宝典》是VBA入门的最佳教材,他也是Microsoft MVP 之一。

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-10-23 11:12 | 显示全部楼层

关键是看懂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编辑过]

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-10-24 13:12 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2008-10-25 03:09 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-10-28 15:56 | 显示全部楼层
很简单啊,就是宏启动时往注册表里写入一个值,以后每次都检查,到0了就加载不了这个宏了。

TA的精华主题

TA的得分主题

发表于 2008-11-12 22:04 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2008-12-2 09:30 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2009-1-30 12:41 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2009-3-7 10:30 | 显示全部楼层
能否分享一下具体步骤 怎么都搞不定的 郁闷
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-8-19 01:04 , Processed in 0.150549 second(s), 22 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表