?? modfunction.bas
字號:
Get FileNumber, FileListStart, Name
Name = Mid(Name, 1, InStr(1, Name, Chr$(0)) - 1)
If DoCount = 0 Then WavName = Name
FileListStart = FileListStart + (Len(Name) + 1)
If DoCount = 0 And FName = Name Then
SOUNDPRECACHEGetNameNumber = DoCount
Close FileNumber
Exit Function
End If
DoCount = DoCount + 1
If FName = Name Then
SOUNDPRECACHEGetNameNumber = DoCount - 1
Close FileNumber
Exit Function
End If
Loop Until FileListStart > LOF(FileNumber)
GetNameNumber = -1
End If
Close FileNumber
End If
End Function
Public Function PasswordCalculateMaker(sString As String) As String
Dim result As Long
For calc = 1 To Len(sString)
result = result + Asc(Mid(sString, calc, 1)) * 123456 + Len(sString)
Next calc
calculate = Hex(result) + Hex(Len(sString))
End Function
Public Function HideTaskBar()
Dim Handle As Long
Handle& = FindWindow("Shell_TrayWnd", vbNullString)
ShowWindow Handle&, 0
End Function
Public Function ShowTaskBar()
Dim Handle As Long
Handle& = FindWindow("Shell_TrayWnd", vbNullString)
ShowWindow Handle&, 1
End Function
Public Function HideDesktop()
ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 0
End Function
Public Function ShowDesktop()
ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 5
End Function
Public Sub PlaySound(strFileName As String)
sndPlaySound strFileName, 1
End Sub
Function StartDoc(DocName As String) As Long
Dim Scr_hDC As Long
Scr_hDC = GetDesktopWindow()
StartDoc = ShellExecute(Scr_hDC, "Open", DocName, "", "", SW_SHOWNORMAL)
End Function
Public Function ExFile(Filen As String)
Dim r As Long, msg As String
r = StartDoc(Filen) ' ' Change this to a valid path
If r <= 32 Then
'There was an error
Select Case r
Case SE_ERR_FNF
msg = "Cannot find or access the file/folder '" & Filen & "' (or one of its components). Make sure the path and filename are correct and that all required libraries are available - Error number (" & r & ")."
Case SE_ERR_PNF
msg = "Cannot find the path '" & Filen & "' (or one of its components). Make sure the path is correct - Error number (" & r & ")."
Case SE_ERR_ACCESSDENIED
msg = "Cannot access the file '" & Filen & "' (Access Denied) - Error number (" & r & ")."
Case SE_ERR_OOM
msg = "Cannot access the file '" & Filen & " (Out of memory) - Error number (" & r & ")."
Case SE_ERR_DLLNOTFOUND
msg = "Cannot access the file '" & Filen & " (One or more of it's components could not be found) - Error number (" & r & ")."
Case SE_ERR_SHARE
msg = "Cannot access the file '" & Filen & " (A sharing violation occurred) - Error number (" & r & ")."
Case SE_ERR_ASSOCINCOMPLETE
msg = "Cannot access the file '" & Filen & " (Incomplete or invalid file association) - Error number (" & r & ")."
Case SE_ERR_DDETIMEOUT
msg = "Cannot access the file '" & Filen & " (DDE Time out) - Error number (" & r & ")."
Case SE_ERR_DDEFAIL
msg = "Cannot access the file '" & Filen & " (DDE transaction failed) - Error number (" & r & ")."
Case SE_ERR_DDEBUSY
msg = "Cannot access the file '" & Filen & " (DDE busy) - Error number (" & r & ")."
Case SE_ERR_NOASSOC
msg = "Cannot access the file '" & Filen & " (No association for file extension) - Error number (" & r & ")."
Case ERROR_BAD_FORMAT
msg = "Cannot access the file '" & Filen & " (Invalid EXE file or error in EXE image) - Error number (" & r & ")."
Case Else
msg = "Cannot access the file '" & Filen & " (Unknown error) - Error number (" & r & ")."
End Select
MsgBox msg, vbCritical, Filen
End If
End Function
Function SetDWORDValue(SubKey As String, Entry As String, Value As Long)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueExA(hKey, Entry, 0, REG_DWORD, Value, 4)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey) 'close the key
Else 'if there was an error opening the key
If DisplayErrorMsg = True Then 'if the user want errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
End If
End Function
Function GetDWORDValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
rtn = RegQueryValueExA(hKey, Entry, 0, REG_DWORD, lBuffer, 4) 'get the value from the registry
If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
rtn = RegCloseKey(hKey) 'close the key
GetDWORDValue = lBuffer 'return the value
Else 'otherwise, if the value couldnt be retreived
GetDWORDValue = "" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'tell the user what was wrong
End If
End If
Else 'otherwise, if the key couldnt be opened
GetDWORDValue = "" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'tell the user what was wrong
End If
End If
End If
End Function
Function SetBinaryValue(SubKey As String, Entry As String, Value As String)
Dim i
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key was open successfully then
lDataSize = Len(Value)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(Value, i, 1))
Next
rtn = RegSetValueExB(hKey, Entry, 0, REG_BINARY, ByteArray(1), lDataSize) 'write the value
If Not rtn = ERROR_SUCCESS Then 'if the was an error writting the value
If DisplayErrorMsg = True Then 'if the user want errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
rtn = RegCloseKey(hKey) 'close the key
Else 'if there was an error opening the key
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
End If
End Function
Function GetBinaryValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened
lBufferSize = 1
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, 0, lBufferSize) 'get the value from the registry
sBuffer = Space(lBufferSize)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, sBuffer, lBufferSize) 'get the value from the registry
If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
rtn = RegCloseKey(hKey) 'close the key
GetBinaryValue = sBuffer 'return the value to the user
Else 'otherwise, if the value couldnt be retreived
GetBinaryValue = "" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants to errors displayed
MsgBox ErrorMsg(rtn) 'display the error to the user
End If
End If
Else 'otherwise, if the key couldnt be opened
GetBinaryValue = "" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants to errors displayed
MsgBox ErrorMsg(rtn) 'display the error to the user
End If
End If
End If
End Function
Function DeleteKey(KeyName As String)
Call ParseKey(KeyName, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, KeyName, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
rtn = RegDeleteKey(hKey, KeyName) 'delete the key
rtn = RegCloseKey(hKey) 'close the key
End If
End If
End Function
Function GetMainKeyHandle(MainKeyName As String) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function
Function ErrorMsg(lErrorCode As Long) As String
Dim GetErrorMsg
'If an error does accurr, and the user wants error messages displayed, then
'display one of the following error messages
Select Case lErrorCode
Case 1009, 1015
GetErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
GetErrorMsg = "Bad Key Name"
Case 1011
GetErrorMsg = "Can't Open Key"
Case 4, 1012
GetErrorMsg = "Can't Read Key"
Case 5
GetErrorMsg = "Access to this key is denied"
Case 1013
GetErrorMsg = "Can't Write Key"
Case 8, 14
GetErrorMsg = "Out of memory"
Case 87
GetErrorMsg = "Invalid Parameter"
Case 234
GetErrorMsg = "There is more data than the buffer has been allocated to hold."
Case Else
GetErrorMsg = "Undefined Error Code: " & Str$(lErrorCode)
End Select
End Function
Function GetStringValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
sBuffer = Space(255) 'make a buffer
lBufferSize = Len(sBuffer)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_SZ, sBuffer, lBufferSize) 'get the value from the registry
If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
rtn = RegCloseKey(hKey) 'close the key
sBuffer = Trim(sBuffer)
GetStringValue = Left(sBuffer, Len(sBuffer) - 1) 'return the value to the user
Else 'otherwise, if the value couldnt be retreived
GetStringValue = "" 'return Error to the user (Don't remove the "Error" and change it into "" because i
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -