registry.bas

office 2000中可以排版维吾尔文字。该程序只能在win98操作系统下正常运行

Attribute VB_Name = "mdlRegistry"

Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003

Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

Global Const KEY_ALL_ACCESS = &H3F
 Const ERROR_SUCCESS = 0
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
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Global Const REG_OPTION_NON_VOLATILE = 0
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
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 RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
        (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _
        (ByVal Hkey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
        ByVal cbName As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long
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, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
 Private Type SECURITY_ATTRIBUTES
   nlenght As Long
   lpsecuritydescriptor As Long
   binherithandle As Boolean
End Type
Public Function updatekey(keyroot As Long, keyname As String, _
subkeyname As String, subkeyvalue As String) As Boolean
   Dim rc As Long
   Dim Hkey As Long
   Dim hdepth As Long
   Dim lpattr As SECURITY_ATTRIBUTES
   lpattr.nlenght = 50
   lpattr.lpsecuritydescriptor = 0
   lpattr.binherithandle = True
         rc = RegOpenKeyEx(keyroot, keyname, 0, KEY_ALL_ACCESS, Hkey)
         If (rc <> ERROR_SUCCESS) Then GoTo ERRORKEYERROR
         rc = RegSetValueEx(Hkey, subkeyname, 0, REG_SZ, ByVal subkeyvalue, LenB(StrConv(subkeyvalue, vbFromUnicode)) + 1)
         If (rc <> ERROR_SUCCESS) Then GoTo ERRORKEYERROR
         rc = RegCloseKey(Hkey)
         updatekey = True
Exit Function
ERRORKEYERROR:
         updatekey = False
         rc = RegCloseKey(Hkey)
End Function

Public 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
            sValue = vValue
            SetValueEx = RegSetValueExString(Hkey, sValueName, 0&, lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(Hkey, sValueName, 0&, lType, lValue, 4)
        End Select

End Function
Public Function CreateNewKey(lPredefinedKey As Long, sNewKeyName As String)
    Dim hNewKey As Long
    Dim lRetVal As Long
    
    lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
    RegCloseKey (hNewKey)
End Function
Sub Main()
Dim lu As String
Dim keytxt As String
Dim strString As String
Dim old_get As String
Dim new_get As String
Dim lu1 As String
 old_get = get_num
lu = ".DEFAULT\keyboard layout\preload\" + old_get
lu1 = "Keyboard Layout\Preload\" + old_get
    CreateNewKey HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\Keyboard Layouts\00000401"
    SetKeyValue HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\Keyboard Layouts\00000401", "layout file", "kbduy.kbd", REG_SZ
    SetKeyValue HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\Keyboard Layouts\00000401", "layout text", "UYGHUR", REG_SZ
    SetKeyValue HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\Nls\Locale", "00000401", "维文输入法", REG_SZ
 CreateNewKey HKEY_USERS, lu
 CreateNewKey HKEY_CURRENT_USER, lu1
new_get = CStr((CInt(old_get) - 1))
While CInt(new_get) >= 2
strString = getstring(HKEY_USERS, ".DEFAULT\keyboard layout\preload\" + new_get, "")
Call savestring(HKEY_USERS, ".DEFAULT\keyboard layout\preload\" + old_get, "", strString)
Call savestring(HKEY_CURRENT_USER, "Keyboard Layout\Preload\" + old_get, "", strString)

 old_get = new_get
 new_get = CStr((CInt(new_get) - 1))

Wend
Call savestring(HKEY_USERS, ".DEFAULT\keyboard layout\preload\2", "", "00000401")
Call savestring(HKEY_CURRENT_USER, "Keyboard Layout\Preload\2", "", "00000401")

 SetKeyValue HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\Nls\CodePage", "1256", "CP_1256.nls", REG_SZ
 
 Const value99 = "王室秘书.exe"
      Dim rs As Long
     rs = RegSetValueEx(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run\Samples", 0, REG_SZ, ByVal value99, LenB(StrConv(value99, vbFromUnicode)) + 1)
      Dim rc As Long
      rc = updatekey(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", "Examples", App.Path + "\王室秘书.exe")
End Sub
Public Function SetKeyValue(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
       Dim lRetVal As Long
       Dim Hkey As Long

       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, Hkey)
       lRetVal = SetValueEx(Hkey, sValueName, lValueType, vValueSetting)
       RegCloseKey (Hkey)

End Function

Public Function get_num() As String
    Dim Hkey As Long
    Dim i
    Dim astr As String * 256
    Dim san As Integer
    san = 0
    If RegOpenKey(HKEY_USERS, ".DEFAULT\keyboard layout\preload", Hkey) = ERROR_SUCCESS Then
    
        While RegEnumKey(Hkey, i, astr, 256) = ERROR_SUCCESS
            If CInt(astr) >= san Then
            san = astr
           End If
            i = i + 1
        Wend
        RegCloseKey Hkey
    End If
  
get_num = CStr(san + 1)
End Function
Public Function getstring(Hkey As Long, strPath As String, strValue As String)

Dim keyhand As Long
Dim datatype As Long
Dim lResult As Long
Dim strBuf As String
Dim lDataBufSize As Long
Dim intZeroPos As Integer
R = RegOpenKey(Hkey, strPath, keyhand)
lResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)
If lValueType = REG_SZ Then
    strBuf = String(lDataBufSize, " ")
    lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)
    If lResult = ERROR_SUCCESS Then
        intZeroPos = InStr(strBuf, Chr$(0))
        If intZeroPos > 0 Then
            getstring = Left$(strBuf, intZeroPos - 1)
        Else
            getstring = strBuf
        End If
    End If
End If
End Function
Public Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)
Dim keyhand As Long
Dim R As Long
R = RegCreateKey(Hkey, strPath, keyhand)
R = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
R = RegCloseKey(keyhand)
End Sub