推 linmic:你真是太盡責了...220.138.220.111 04/17
' 請自行從 API 檢視員中找出下列函式：
' RegCreateKey、RegOpenKey、RegQueryValueEx、ExpandEnvironmentStrings
' RegSetValueEx、lStrLenB
' 以及常數：
' HKEY_CURRENT_USER、REG_BINARY、REG_DWORD、REG_SZ、REG_DWORD_BIG_ENDIAN
' REG_MULTI_SZ、REG_EXPAND_SZ
'
' 並且在適當的地方給 data1 一個初始值...(Now / 24)
' ex. 安裝程式
'
' P.S. 沒有測試過，不確定會不會有錯誤=_=
Option Explicit
Sub Main()
On Error Goto ErrProc
'程式進入點
Dim lngNum As Long, hKey As Long, SoftPath As String, ret1, ret2, x, y
SoftPath = "SOFTWARE\公司名稱\軟體名稱"
ret1 = GetKeyValue(HKEY_CURRENT_USER, SoftPath, "data1", 0, 0) * 24
ret2 = GetKeyValue(HKEY_CURRENT_USER, SoftPath, "data2", 0, 0) * 24
x = Now - ret2 '現在時間與上次使用時間的差距(單位:天)
'避免偷改系統時間的偷雞行為
y = ret2 - ret1 '總共使用天數
If x <= 0 Or x >= 30 Or y <= 0 Or y >= 30 Then
Msgbox "30天試用期限已到，請購買正式版。", vbInformation
End
End If
'記錄這次使用的時間
If RegCreateKey(HKEY_CURRENT_USER, SoftPath, hKey) <> 0 Then Err.Raise 5
If Not SetKeyValue(hKey, "data2", Now / 24) Then Err.Raise 5
'檢查完成，載入表單
Load Form1
Form1.Show
Exit Sub
errProc:
Msgbox "程式發生錯誤", vbInformation
End Sub
Public Function GetKeyValue(ByVal RootPath As Long, ByVal KeyPath As String, _
ByVal KeyName As String, KeyType, Optional DefaultValue)
On Error GoTo errProc
Dim hKey As Long, ret As Long, lenData As Long, typeData As Long
If RegOpenKey(RootPath, KeyPath, hKey) <> 0 Then GoSub NotFoundProc
If RegQueryValueEx(hKey, KeyName, 0, typeData, ByVal vbNullString, _
lenData) <> 0 Then GoSub NotFoundProc: GoTo EndProc
If typeData = REG_SZ Or typeData = REG_EXPAND_SZ Or _
typeData = REG_MULTI_SZ Then 'Data type is String
Dim s As String
s = String(lenData, Chr(0))
RegQueryValueEx hKey, KeyName, 0, typeData, ByVal s, lenData
If typeData = REG_SZ Then 'Normal string
If s <> "" Then s = Left(s, InStr(s, Chr(0)) - 1)
GetKeyValue = s: KeyType = vbString
ElseIf typeData = REG_EXPAND_SZ Then 'String which is have %WINPATH%
Dim s2 As String
s2 = String(Len(s) + 256, Chr(0))
ExpandEnvironmentStrings s, s2, Len(s2)
GetKeyValue = Left(s2, InStr(s2, Chr(0)) - 1): KeyType = vbString
ElseIf typeData = REG_MULTI_SZ Then 'String which is a array
GetKeyValue = Split(Left(s, Len(s) - 2), Chr(0)): KeyType = vbArray
End If
ElseIf typeData = REG_DWORD Or typeData = REG_DWORD_BIG_ENDIAN Then
'Data type is dword
Dim l As Long: RegQueryValueEx hKey, KeyName, 0, typeData, l, lenData
GetKeyValue = l: KeyType = vbLong
ElseIf typeData = REG_BINARY Then 'Data type is binary
If lenData = 0 Then
GetKeyValue = "": KeyType = vbNull
Else
ReDim bArr(lenData - 1) As Byte
RegQueryValueEx hKey, KeyName, 0, typeData, bArr(0), lenData
GetKeyValue = StrConv(bArr, vbUnicode): KeyType = vbByte
End If
End If
EndProc:
RegCloseKey hKey: Exit Function
NotFoundProc:
GetKeyValue = DefaultValue: GoTo EndProc
errProc:
Debug.Print Err.Description: GetKeyValue = Empty: Resume EndProc
End Function
Public Function SetKeyValue(ByVal hKey As Long, ByVal KeyName As String, _
ByVal KeyValue) As Boolean
On Error GoTo errProc
Dim ret As Long, KeyLength As Long, i As Single, j As Single, kv As Single
kv = VarType(KeyValue)
If kv = vbDate Or kv = vbString Or kv = vbDecimal Or kv = vbSingle Or _
kv = vbDouble Then
KeyLength = lStrLenB(KeyValue) + 1
If KeyValue = "" Then KeyLength = 0
ret = RegSetValueEx(hKey, KeyName, 0, REG_SZ, ByVal CStr(KeyValue), _
KeyLength)
If ret = 0 Then SetKeyValue = True
ElseIf kv = vbInteger Or kv = vbLong Or kv = vbBoolean Then
Dim tv As Long: tv = KeyValue
ret = RegSetValueEx(hKey, KeyName, 0, REG_DWORD, tv, LenB(tv))
If ret = 0 Then SetKeyValue = True
ElseIf kv = vbByte Or kv = vbByte + vbArray Or kv = vbArray Then
If kv = vbArray Then
i = lStrLenB(KeyValue) - 1
Else
i = UBound(KeyValue)
End If
ReDim bValue(i) As Byte
For j = 0 To i
If kv = vbArray Then
bValue(j) = AscB(MidB(StrConv(KeyValue, vbFromUnicode), j, 1))
Else
bValue(j) = KeyValue(j)
End If
Next
ret = RegSetValueEx(hKey, KeyName, 0, REG_BINARY, bValue(0), _
UBound(bValue) + 1)
If ret = 0 Then SetKeyValue = True
Else
SetKeyValue = False
End If
Exit Function
errProc:
Debug.Print Err.Description: SetKeyValue = False
End Function
--
VB 程式設計 倉木麻衣 PTT 星爺板 行列輸入法
======================================================
Visual_Basic MaiKuraki Stephen Array
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 210.58.156.43