'--------------------------------------------------------------- '- 注冊表 api 聲明... '--------------------------------------------------------------- private declare function regclosekey lib "advapi32.dll" (byval hkey as long) as long private declare function regcreatekeyex lib "advapi32.dll" alias "regcreatekeyexa" (byval hkey as long, byval lpsubkey as string, byval reserved as long, byval lpclass as string, byval dwoptions as long, byval samdesired as long, lpsecurityattributes as security_attributes, phkresult as long, lpdwdisposition as long) as long private declare function regdeletekey lib "advapi32.dll" alias "regdeletekeya" (byval hkey as long, byval lpsubkey as string) as long private declare function regdeletevalue lib "advapi32.dll" alias "regdeletevaluea" (byval hkey as long, byval lpvaluename as string) as long private declare function regopenkeyex lib "advapi32.dll" alias "regopenkeyexa" (byval hkey as long, byval lpsubkey as string, byval uloptions as long, byval samdesired as long, phkresult as long) as long private declare function regqueryvalueex lib "advapi32.dll" alias "regqueryvalueexa" (byval hkey as long, byval lpvaluename as string, byval lpreserved as long, lptype as long, lpdata as any, lpcbdata as long) as long private declare function regrestorekey lib "advapi32.dll" alias "regrestorekeya" (byval hkey as long, byval lpfile as string, byval dwflags as long) as long private declare function regsavekey lib "advapi32.dll" alias "regsavekeya" (byval hkey as long, byval lpfile as string, lpsecurityattributes as security_attributes) as long private declare function regsetvalueex lib "advapi32.dll" alias "regsetvalueexa" (byval hkey as long, byval lpvaluename as string, byval reserved as long, byval dwtype as long, lpdata as any, byval cbdata as long) as long private declare function regqueryinfokey lib "advapi32.dll" alias "regqueryinfokeya" (byval hkey as long, byval lpclass as string, lpcbclass as long, byval lpreserved as long, lpcsubkeys as long, lpcbmaxsubkeylen as long, lpcbmaxclasslen as long, lpcvalues as long, lpcbmaxvaluenamelen as long, lpcbmaxvaluelen as long, lpcbsecuritydescriptor as long, lpftlastwritetime as filetime) as long private declare function regenumvalue lib "advapi32.dll" alias "regenumvaluea" (byval hkey as long, byval dwindex as long, byval lpvaluename as string, lpcbvaluename as long, byval lpreserved as long, lptype as long, lpdata as byte, lpcbdata as long) as long private declare function regenumkeyex lib "advapi32.dll" alias "regenumkeyexa" (byval hkey as long, byval dwindex as long, byval lpname as string, lpcbname as long, byval lpreserved as long, byval lpclass as string, lpcbclass as long, lpftlastwritetime as filetime) as long
private declare function adjusttokenprivileges lib "advapi32.dll" (byval tokenhandle as long, byval disableallpriv as long, newstate as token_privileges, byval bufferlength as long, previousstate as token_privileges, returnlength as long) as long 'used to adjust your program's security privileges, can't restore without it! private declare function lookupprivilegevalue lib "advapi32.dll" alias "lookupprivilegevaluea" (byval lpsystemname as any, byval lpname as string, lpluid as luid) as long 'returns a valid luid which is important when making security changes in nt. private declare function openprocesstoken lib "advapi32.dll" (byval processhandle as long, byval desiredaccess as long, tokenhandle as long) as long private declare function getcurrentprocess lib "kernel32" () as long
' 有關導入/導出的常量 const reg_force_restore as long = 8& const token_query as long = &h8& const token_adjust_privileges as long = &h20& const se_privilege_enabled as long = &h2 const se_restore_name = "serestoreprivilege" const se_backup_name = "sebackupprivilege"
'--------------------------------------------------------------- '- 注冊表類型... '--------------------------------------------------------------- private type security_attributes nlength as long lpsecuritydescriptor as long binherithandle as boolean end type
private type filetime dwlowdatetime as long dwhighdatetime as long end type
private type luid lowpart as long highpart as long end type
private type luid_and_attributes pluid as luid attributes as long end type
private type token_privileges privilegecount as long privileges as luid_and_attributes end type
private hkey as long ' 注冊表打開項的句柄 private i as long, j as long ' 循環變量 private success as long ' api函數的返回值, 判斷函數調用是否成功
'------------------------------------------------------------------------------------------------------------- '- 新建注冊表關鍵字并設置注冊表關鍵字的值... '- 如果 valuename 和 value 都缺省, 則只新建 keyname 空項, 無子鍵... '- 如果只缺省 valuename 則將設置指定 keyname 的默認值 '- 參數說明: keyroot--根類型, keyname--子項名稱, valuename--值項名稱, value--值項數據, valuetype--值項類型 '------------------------------------------------------------------------------------------------------------- public function setkeyvalue(keyroot as keyroot, keyname as string, optional valuename as string, optional value as variant = "", optional valuetype as valuetype = reg_sz) as boolean dim lpattr as security_attributes ' 注冊表安全類型 lpattr.nlength = 50 ' 設置安全屬性為缺省值... lpattr.lpsecuritydescriptor = 0 ' ... lpattr.binherithandle = true ' ...
' 新建注冊表關鍵字... success = regcreatekeyex(keyroot, keyname, 0, valuetype, reg_option_non_volatile, key_all_access, lpattr, hkey, 0) if success <> error_success then setkeyvalue = false: regclosekey hkey: exit function
' 設置注冊表關鍵字的值... if ismissing(valuename) = false then select case valuetype case reg_sz, reg_expand_sz, reg_multi_sz success = regsetvalueex(hkey, valuename, 0, valuetype, byval cstr(value), lenb(strconv(value, vbfromunicode)) + 1) case reg_dword if cdbl(value) <= 4294967295# and cdbl(value) >= 0 then dim svalue as string svalue = doubletohex(value) dim dvalue(3) as byte dvalue(0) = format("&h" & mid(svalue, 7, 2)) dvalue(1) = format("&h" & mid(svalue, 5, 2)) dvalue(2) = format("&h" & mid(svalue, 3, 2)) dvalue(3) = format("&h" & mid(svalue, 1, 2)) success = regsetvalueex(hkey, valuename, 0, valuetype, dvalue(0), 4) else success = error_badkey end if case reg_binary on error resume next success = 1 ' 假設調用api不成功(成功返回0) redim tmpvalue(ubound(value)) as byte for i = 0 to ubound(tmpvalue) tmpvalue(i) = value(i) next i success = regsetvalueex(hkey, valuename, 0, valuetype, tmpvalue(0), ubound(value) + 1) end select end if if success <> error_success then setkeyvalue = false: regclosekey hkey: exit function
' 關閉注冊表關鍵字... regclosekey hkey setkeyvalue = true ' 返回函數值 end function
'------------------------------------------------------------------------------------------------------------- '- 獲得已存在的注冊表關鍵字的值... '- 如果 valuename="" 則返回 keyname 項的默認值... '- 如果指定的注冊表關鍵字不存在, 則返回空串... '- 參數說明: keyroot--根類型, keyname--子項名稱, valuename--值項名稱, valuetype--值項類型 '------------------------------------------------------------------------------------------------------------- public function getkeyvalue(keyroot as keyroot, keyname as string, valuename as string, optional valuetype as long) as string dim tempvalue as string ' 注冊表關鍵字的臨時值 dim value as string ' 注冊表關鍵字的值 dim valuesize as long ' 注冊表關鍵字的值的實際長度 tempvalue = space(1024) ' 存儲注冊表關鍵字的臨時值的緩沖區 valuesize = 1024 ' 設置注冊表關鍵字的值的默認長度
' 返回注冊表關鍵字的的值... select case valuetype ' 通過判斷關鍵字的類型, 進行處理 case reg_sz, reg_multi_sz, reg_expand_sz tempvalue = left$(tempvalue, valuesize - 1) ' 去掉tempvalue尾部空格 value = tempvalue case reg_dword redim dvalue(3) as byte regqueryvalueex hkey, valuename, 0, reg_dword, dvalue(0), valuesize for i = 3 to 0 step -1 value = value + string(2 - len(hex(dvalue(i))), "0") + hex(dvalue(i)) ' 生成長度為8的十六進制字符串 next i if cdbl("&h" & value) < 0 then ' 將十六進制的 value 轉換為十進制 value = 2 ^ 32 + cdbl("&h" & value) else value = cdbl("&h" & value) end if case reg_binary if valuesize > 0 then redim bvalue(valuesize - 1) as byte ' 存儲 reg_binary 值的臨時數組 regqueryvalueex hkey, valuename, 0, reg_binary, bvalue(0), valuesize for i = 0 to valuesize - 1 value = value + string(2 - len(hex(bvalue(i))), "0") + hex(bvalue(i)) + " " ' 將數組轉換成字符串 next i end if end select
' 關閉注冊表關鍵字... regclosekey hkey getkeyvalue = trim(value) ' 返回函數值 end function
'------------------------------------------------------------------------------------------------------------- '- 刪除已存在的注冊表關鍵字的值... '- 如果指定的注冊表關鍵字不存在, 則不做任何操作... '- 參數說明: keyroot--根類型, keyname--子項名稱, valuename--值項名稱 '------------------------------------------------------------------------------------------------------------- public function deletekey(keyroot as keyroot, keyname as string, optional valuename as string) as boolean dim tmpkeyname as string ' 注冊表關鍵字的臨時子項名稱 dim tmpvaluename as string ' 注冊表關鍵字的臨時子鍵名稱
' 打開一個已存在的注冊表關鍵字... success = regopenkeyex(keyroot, keyname, 0, key_all_access, hkey) if success <> error_success then deletekey = false: regclosekey hkey: exit function
' 刪除已打開的注冊表關鍵字... tmpkeyname = "" tmpvaluename = keyname if valuename = "" then ' 判斷valuename是否缺省, 如缺省作相應處理 if instrrev(keyname, "/") > 1 then tmpvaluename = right(keyname, instrrev(keyname, "/") + 1) tmpkeyname = left(keyname, instrrev(keyname, "/") - 1) end if success = regopenkeyex(keyroot, tmpkeyname, 0, key_all_access, hkey) success = regdeletekey(hkey, tmpvaluename) else success = regdeletevalue(hkey, valuename) end if if success <> error_success then deletekey = false: regclosekey hkey: exit function
' 關閉注冊表關鍵字... regclosekey hkey deletekey = true ' 返回函數值 end function
'------------------------------------------------------------------------------------------------------------- '- 獲得注冊表關鍵字的一些信息... '- subkeyname() 注冊表關鍵字的所有子項的名稱(注意:最小下標為0) '- valuename() 注冊表關鍵字的所有子鍵的名稱(注意:最小下標為0) '- valuetype() 注冊表關鍵字的所有子鍵的類型(注意:最小下標為0) '- countkey 注冊表關鍵字的子項數量 '- countvalue 注冊表關鍵字的子鍵數量 '- maxlenkey 注冊表關鍵字的子項名稱的最大長度 '- maxlenvalue 注冊表關鍵字的子鍵名稱的最大長度 '------------------------------------------------------------------------------------------------------------- public function getkeyinfo(keyroot as keyroot, keyname as string, subkeyname() as string, valuename() as string, valuetype() as valuetype, optional countkey as long, optional countvalue as long, optional maxlenkey as long, optional maxlenvalue as long) as boolean dim f as filetime dim l as long, s as string
' 打開一個已存在的注冊表關鍵字... success = regopenkeyex(keyroot, keyname, 0, key_all_access, hkey) if success <> error_success then getkeyinfo = false: regclosekey hkey: exit function
if countkey <> 0 then redim subkeyname(countkey - 1) as string ' 重新定義數組, 使用數組大小與注冊表關鍵字的子項數量匹配 for i = 0 to countkey - 1 subkeyname(i) = space(255) l = 255 regenumkeyex hkey, i, byval subkeyname(i), l, 0, vbnullstring, byval 0&, f subkeyname(i) = left(subkeyname(i), l) next i
' 下面的二重循環對字符串數組進行冒泡排序 for i = 0 to ubound(subkeyname) for j = i + 1 to ubound(subkeyname) if subkeyname(i) > subkeyname(j) then s = subkeyname(i) subkeyname(i) = subkeyname(j) subkeyname(j) = s end if next j next i end if
if countvalue <> 0 then redim valuename(countvalue - 1) as string ' 重新定義數組, 使用數組大小與注冊表關鍵字的子鍵數量匹配 redim valuetype(countvalue - 1) as long ' 重新定義數組, 使用數組大小與注冊表關鍵字的子鍵數量匹配 for i = 0 to countvalue - 1 valuename(i) = space(255) l = 255 regenumvalue hkey, i, byval valuename(i), l, 0, valuetype(i), byval 0&, byval 0& valuename(i) = left(valuename(i), l) next i
' 下面的二重循環對字符串數組進行冒泡排序 for i = 0 to ubound(valuename) for j = i + 1 to ubound(valuename) if valuename(i) > valuename(j) then s = valuename(i) valuename(i) = valuename(j) valuename(j) = s end if next j next i end if
' 關閉注冊表關鍵字... regclosekey hkey getkeyinfo = true ' 返回函數值 end function
'------------------------------------------------------------------------------------------------------------- '- 導出注冊表關鍵字的值 '- 參數說明: keyroot--根類型, keyname--子項名稱, filename--導出的文件路徑及文件名(原始數據庫格式) '------------------------------------------------------------------------------------------------------------- public function savekey(keyroot as keyroot, keyname as string, filename as string) as boolean on error resume next
if enableprivilege(se_backup_name) = false then savekey = false exit function end if
success = regopenkeyex(keyroot, keyname, 0&, key_all_access, hkey) if success <> 0 then savekey = false success = regclosekey(hkey) exit function end if
success = regsavekey(hkey, filename, lpattr) if success = 0 then savekey = true else savekey = false
success = regclosekey(hkey) end function
'------------------------------------------------------------------------------------------------------------- '- 導入注冊表關鍵字的值 '- 參數說明: keyroot--根類型, keyname--子項名稱, filename--導入的文件路徑及文件名(原始數據庫格式) '------------------------------------------------------------------------------------------------------------- public function restorekey(keyroot as keyroot, keyname as string, filename as string) as boolean on error resume next
if enableprivilege(se_restore_name) = false then restorekey = false exit function end if
success = regopenkeyex(keyroot, keyname, 0&, key_all_access, hkey) if success <> 0 then restorekey = false success = regclosekey(hkey) exit function end if
success = regrestorekey(hkey, filename, reg_force_restore) if success = 0 then restorekey = true else restorekey = false
success = regclosekey(hkey) end function
'------------------------------------------------------------------------------------------------------------- '- 使注冊表允許導入/導出 '------------------------------------------------------------------------------------------------------------- private function enableprivilege(sename as string) as boolean on error resume next
dim p_lngrtn as long dim p_lngtoken as long dim p_lngbufferlen as long dim p_typluid as luid dim p_typtokenpriv as token_privileges dim p_typprevtokenpriv as token_privileges
p_lngrtn = openprocesstoken(getcurrentprocess(), token_adjust_privileges or token_query, p_lngtoken) if p_lngrtn = 0 then enableprivilege = false exit function end if if err.lastdllerror <> 0 then enableprivilege = false exit function end if
p_lngrtn = lookupprivilegevalue(0&, sename, p_typluid) if p_lngrtn = 0 then enableprivilege = false exit function end if
enableprivilege = (adjusttokenprivileges(p_lngtoken, false, p_typtokenpriv, len(p_typprevtokenpriv), p_typprevtokenpriv, p_lngbufferlen) <> 0) end function
'------------------------------------------------------------------------------------------------------------- '- 將 double 型( 限制在 0--2^32-1 )的數字轉換為十六進制并在前面補零 '- 參數說明: number--要轉換的 double 型數字 '------------------------------------------------------------------------------------------------------------- private function doubletohex(byval number as double) as string dim strhex as string strhex = space(8) for i = 1 to 8 select case number - int(number / 16) * 16 case 10 mid(strhex, 9 - i, 1) = "a" case 11 mid(strhex, 9 - i, 1) = "b" case 12 mid(strhex, 9 - i, 1) = "c" case 13 mid(strhex, 9 - i, 1) = "d" case 14 mid(strhex, 9 - i, 1) = "e" case 15 mid(strhex, 9 - i, 1) = "f" case else mid(strhex, 9 - i, 1) = cstr(number - int(number / 16) * 16) end select number = int(number / 16) next i doubletohex = strhex end function
