basregistry.bas

可直接打开编辑网络数据库

    
    appPath = Replace(appPath, "\\", "\")
    
    If appName = "" Then
        appTitle = "TC网络数据库系统"
    Else
        appTitle = appName
    End If
    
    If GetSetting("." & LCase(extension), "", "", appTitle, HKEY_CLASSES_ROOT, "") = appTitle Then
        setDefault = True
    End If
    
    If setDefault = True Then
        lRetVal = RegCreateKeyEx(HKEY_CLASSES_ROOT, appTitle, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRetVal)
        lRetVal = SetValueEx(hKey, "", REG_SZ, appTitle)
        RegCloseKey (hKey)
    
        lRetVal = RegCreateKeyEx(HKEY_CLASSES_ROOT, "." & LCase(extension), 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRetVal)
        lRetVal = SetValueEx(hKey, "", REG_SZ, appTitle)
        RegCloseKey (hKey)
    End If
    
    If setDefault = False Then
        If GetSetting("." & LCase(extension), "", "", "", HKEY_CLASSES_ROOT, "") <> "" Then
            appKey = GetSetting("." & LCase(extension), "", "", "", HKEY_CLASSES_ROOT, "")
        Else
            appKey = appTitle
        End If
        commandString = appKey & "\shell\Open2"
    Else
        appKey = appTitle
        commandString = appTitle & "\shell\Open"
    End If
    
    lRetVal = RegCreateKeyEx(HKEY_CLASSES_ROOT, commandString & "\command", 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRetVal)
    lRetVal = SetValueEx(hKey, "", REG_SZ, """" & appPath & """ %1")
    RegCloseKey (hKey)
    
    If appTitle <> "" Then
        lRetVal = RegCreateKeyEx(HKEY_CLASSES_ROOT, commandString, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRetVal)
        lRetVal = SetValueEx(hKey, "", REG_SZ, "Open with " & appTitle)
        RegCloseKey (hKey)
    End If
    
    If useNotepadToEdit = True Then
        lRetVal = RegCreateKeyEx(HKEY_CLASSES_ROOT, appKey & "\shell\Edit\command", 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRetVal)
        lRetVal = SetValueEx(hKey, "", REG_SZ, "notepad.exe %1")
        RegCloseKey (hKey)
    ElseIf GetSetting(appTitle & "\shell\Edit", "command", "", "", HKEY_CLASSES_ROOT, "") <> "" Then
        Call DeleteSetting(appTitle & "\shell", "Edit", "", HKEY_CLASSES_ROOT, "", True)
    End If
    
    If setDefault = True Then
        lRetVal = RegCreateKeyEx(HKEY_CLASSES_ROOT, appKey & "\DefaultIcon", 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRetVal)
        lRetVal = SetValueEx(hKey, "", REG_SZ, appPath)
        RegCloseKey (hKey)
    End If

    AssociateFileType = True
    Exit Function
e_Trap:
    AssociateFileType = False
    Exit Function

End Function

Public Sub CreateRunOnStartup(Optional ByVal appTitle As String, Optional ByVal appPath As String, Optional ByVal commandLine As String, Optional ByVal hKeyName As hKeyNames = HKEY_CURRENT_USER)
    If commandLine <> "" Then
        commandLine = " " & commandLine
    End If
    If appTitle = "" Then
        appTitle = "TC网络数据库系统"
    End If
    If appPath = "" Then
        appPath = App.Path & "\" & App.EXEName & ".exe"
    End If
    Call SaveSetting("CurrentVersion", "Run", appTitle, appPath & commandLine, hKeyName, "Software\Microsoft\Windows")
End Sub
Public Sub DeleteRunOnStartup(Optional ByVal appTitle As String, Optional hKeyName As hKeyNames = HKEY_CURRENT_USER)
    Call DeleteSetting("CurrentVersion", "Run", appTitle, hKeyName, "Software\Microsoft\Windows")
End Sub

Public Sub SetDcomComputer(RemoteServerClassName As String, RemoteComputerName As String, Optional runLocal As Boolean = False, Optional UserName As String, Optional Password As String)
Dim defaultPath As String
Dim CLSID As String

    CLSID = GetSetting(RemoteServerClassName, "Clsid", "", "", HKEY_CLASSES_ROOT, "")
    If CLSID <> "" Then
        If GetSetting(CLSID, "", "", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID") = RemoteServerClassName Then
            If runLocal = False Then
                If GetSetting(CLSID, "_LocalServer32", "", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID") = "" Then
                    defaultPath = GetSetting(CLSID, "LocalServer32", "", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID")
                End If
                Call SaveSetting("", CLSID, "RemoteServerName", RemoteComputerName, HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\AppID")
                Call DeleteSetting(CLSID, "LocalServer32", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID")
                If defaultPath <> "" Then
                    Call SaveSetting(CLSID, "_LocalServer32", "", defaultPath, HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID")
                End If
            Else
                If GetSetting(CLSID, "LocalServer32", "", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID") = "" Then
                    defaultPath = GetSetting(CLSID, "_LocalServer32", "", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID")
                End If
                Call SaveSetting(CLSID, "", "AppID", CLSID, HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID")

                
                Call DeleteSetting("AppID", CLSID, "RemoteServerName", HKEY_LOCAL_MACHINE, "SOFTWARE\Classes")
                Call DeleteSetting(CLSID, "_LocalServer32", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID")
                If defaultPath <> "" Then
                    Call SaveSetting(CLSID, "LocalServer32", "", defaultPath, HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID")
                End If
            End If
        End If
    End If
            
End Sub

Public Function GetIniInt(Section As String, Key As String, IniLocation As String, Optional Default As Long) As Long
    GetIniInt = GetPrivateProfileInt(Section, Key, Default, IniLocation)
End Function
Public Function GetIniString(Section As String, Key As String, IniLocation As String, Optional Default As String) As String
Dim ReturnValue As String * 128
Dim i, sLet
Dim iLen As Long
Dim Length As Long
        Length = GetPrivateProfileString(Section, Key, Default, ReturnValue, 128, IniLocation)
        i = InStr(1, Trim(ReturnValue), Chr(0))
        iLen = Len(Trim(ReturnValue))
        GetIniString = CStr(Left(Trim(ReturnValue), (i - 1)))
End Function
Public Function SaveIniString(Section As String, Key As String, Setting As String, IniLocation As String) As Long
    Setting = Replace(Setting, "[", "")
    Setting = Replace(Setting, "]", "")
    SaveIniString = WritePrivateProfileString(Section, Key, Setting, IniLocation)
End Function

Public Sub VerifyPath(pathString As String)
Dim CurrentPath As String

    pathString = Trim(pathString)
    If pathString = "" Then Exit Sub
    
    CurrentPath = Environ("PATH")
    If Mid(pathString, 1, 1) = ";" Then
        pathString = Mid(pathString, 2)
    End If
    If Mid(pathString, Len(pathString), 1) = ";" Then
        pathString = Mid(pathString, 1, Len(pathString) - 1)
    End If
    If InStr(1, UCase(CurrentPath), UCase(pathString), vbTextCompare) = 0 Then
        If Mid(CurrentPath, Len(CurrentPath), 1) = ";" Then
            Environ("PATH") = CurrentPath & pathString
        Else
            Environ("PATH") = CurrentPath & ";" & pathString
        End If
    End If
End Sub

Public Function resolveHkeyLong(hKeyName As String) As hKeyNames
    Select Case UCase(hKeyName)
        Case "HKEY_CURRENT_USER"
            resolveHkeyLong = HKEY_CURRENT_USER
        Case "HKEY_LOCAL_MACHINE"
            resolveHkeyLong = HKEY_LOCAL_MACHINE
        Case "HKEY_USERS"
            resolveHkeyLong = HKEY_USERS
        Case "HKEY_CLASSES_ROOT"
            resolveHkeyLong = HKEY_CLASSES_ROOT
        Case "HKEY_CURRENT_CONFIG"
            resolveHkeyLong = HKEY_CURRENT_CONFIG
    End Select
End Function
Public Function resolveHkeyString(hKeyName As hKeyNames) As String
    Select Case UCase(hKeyName)
        Case HKEY_CURRENT_USER
            resolveHkeyString = "HKEY_CURRENT_USER"
        Case HKEY_LOCAL_MACHINE
            resolveHkeyString = "HKEY_LOCAL_MACHINE"
        Case HKEY_USERS
            resolveHkeyString = "HKEY_USERS"
        Case HKEY_CLASSES_ROOT
            resolveHkeyString = "HKEY_CLASSES_ROOT"
        Case HKEY_CURRENT_CONFIG
            resolveHkeyString = "HKEY_CURRENT_CONFIG"
    End Select
End Function

' Private Functions
Private Function CompileKeyString(Optional AppNameHeader As String, Optional appName As String, Optional Section As String, Optional Key As String) As String
    If AppNameHeader <> "" Then
        CompileKeyString = AppNameHeader
    End If
    If appName <> "" Then
        If CompileKeyString <> "" Then
            CompileKeyString = CompileKeyString & "\"
        End If
        CompileKeyString = CompileKeyString & appName
    End If
    If Section <> "" Then
        If CompileKeyString <> "" Then
            CompileKeyString = CompileKeyString & "\"
        End If
        CompileKeyString = CompileKeyString & Section
    End If
    If Key <> "" Then
        If CompileKeyString <> "" Then
            CompileKeyString = CompileKeyString & "\"
        End If
        CompileKeyString = CompileKeyString & Key
    End If
    Do While InStr(1, CompileKeyString, "\\", vbTextCompare) <> 0
        If InStr(1, CompileKeyString, "\\", vbTextCompare) <> 0 Then
            CompileKeyString = Mid(CompileKeyString, 1, InStr(1, CompileKeyString, "\\", vbTextCompare) - 1) & Mid(CompileKeyString, InStr(1, CompileKeyString, "\\", vbTextCompare) + 1)
        End If
    Loop

    Do While InStr(1, CompileKeyString, "/", vbTextCompare) <> 0
        If InStr(1, CompileKeyString, "/", vbTextCompare) <> 0 Then
            CompileKeyString = Mid(CompileKeyString, 1, InStr(1, CompileKeyString, "/", vbTextCompare) - 1) & "\" & Mid(CompileKeyString, InStr(1, CompileKeyString, "/", vbTextCompare) + 1)
        End If
    Loop

End Function
Private Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
    Dim lValue As Long
    Dim sValue As String
    Select Case lType
        Case REG_SZ, REG_EXPAND_SZ
            sValue = vValue & Chr$(0)
            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
        Case REG_DWORD, REG_DWORD_BIG_ENDIAN
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
        End Select
End Function

Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant, Optional dataType As Long) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String
    Dim Count As Integer
    Dim Holder As String
    Dim NewVal As String

    On Error GoTo QueryValueExError
    vValue = ""
    
    
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5

    dataType = lType
    Select Case lType
        
        Case REG_SZ, REG_EXPAND_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch - 1)
            Else
                vValue = Empty
            End If
       
        Case REG_DWORD, REG_DWORD_BIG_ENDIAN:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue
        Case REG_BINARY
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            If lrc = ERROR_NONE Then
                Holder = Left$(sValue, cch - 1)
                vValue = ""
                For Count = 1 To Len(Holder)
                    NewVal = Format(Hex(Asc(Mid(Holder, Count, 1))), "00")
                    If Len(NewVal) = 1 Then
                        NewVal = "0" & NewVal
                    End If
                    vValue = vValue & NewVal & " "
                Next Count
                vValue = Trim(vValue)
            Else
                vValue = Empty
            End If
            
        Case Else

            lrc = -1
    End Select

QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
QueryValueExError:
    Resume QueryValueExExit
End Function