تغییر ریجستری با استفاده از کد vba

[strong46202]

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\12.0\ Access Connectivity Engine\Engines\ACE\MaxBufferSize


یکی از دوستان گفته بود با تغییر سایز بافر میشه سرعت اجرای اکسس رو افزایش داد. حالا من میخوام این کد رو در form_load بزارم تا با این روش تا اندازه ای سرعت کم لود شدن فرم ها رو جبران کنم....کسی از دوستان میدونه که چطور با کد vba میشه میزان بافر رو در ریجستری افزایش بدم ؟

[ARData]

اين کد ايجاد لود شدن يک برنامه در هنگام باز شدن ويندوز هست با توجه به عمکرد اين کد شما مي توانيد با معادل سازي نمونه خودتان به اجراش بذاريد :
Dim StrArshadLen As Variant
StrArshadLen = Len("C:\Windows\System32\regedit.exe")

Dim r As Long
r = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", keyhand)
r = RegSetValueEx(keyhand, "Regedt", 0, REG_SZ, ByVal ("C:\Windows\System32\regedit.exe"), StrArshadLen)
r = RegCloseKey(keyhand)

[ARData]

البته استفاده از کل توابع Api مربوط به رجيستري به صرت زير مي باشد :
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003


Private Const ERROR_SUCCESS = 0
Private Const ERROR_NONE = 0

Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_ALL_ACCESS = &H3F


'فراخواني کدهاي API جهت نوشتن رجيستري
'بستن کليد رجيستري
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'ايجاد کليد رجيستري
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) 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 RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
'پرس جوي يک مقدار از نوع Long در رجيستري
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
'پرس و جوي مقدار خالي در رجيستري
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData 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
'ذخيره يک مقدار
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
'حذف کليد (Key)
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

Private Sub SaveValue(hKey As Long, strPath As String, strvalue As String, strData As String)

Dim ret
'ايجاد کليد جديد
RegCreateKey hKey, strPath, ret
'ذخيره مقدار در کليد
RegSetValueEx ret, strvalue, 0, REG_SZ, ByVal strData, Len(strData)
'بستن کليد (Key)
RegCloseKey ret

End Sub

Private Sub QueryValue(sKeyName As String, sValueName As String)

Dim lRetVal As Long
Dim hKey As Long
Dim vValue As Variant

lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, KEY_QUERY_VALUE, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
frmRegistry.Caption = vValue
RegCloseKey (hKey)

End Sub

Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long

Dim Data As Long
Dim retval As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String

On Error GoTo QueryValueExError


retval = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, Data)

If retval <> ERROR_NONE Then Error 5

Select Case lType

Case REG_SZ:
sValue = String(Data, 0)

retval = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, Data)

If retval = ERROR_NONE Then
vValue = Left$(sValue, Data - 1)
Else
vValue = Empty
End If


Case REG_DWORD:
retval = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, Data)

If retval = ERROR_NONE Then vValue = lValue

Case Else

retval = -1
End Select

QueryValueExError:
QueryValueEx = retval
Exit Function

End Function
Private Sub cmdCreateKey_Click()

SaveValue HKEY_LOCAL_MACHINE, "Software\" & CurrentProject.Name, "Test", "Testing123"

End Sub

Private Sub cmdDelete_Click()

DeleteSetting CurrentProject.Name, "Form Location"

cmdGet.Enabled = False

MsgBox "The section - Form Location - has been deleted from the " & CurrentProject.Name & " Registry Key"

End Sub

Private Sub cmdDeleteKey_Click()

RegDeleteKey HKEY_LOCAL_MACHINE, "Software\" & CurrentProject.Name

MsgBox "The key - " & CurrentProject.Name & " - has been deleted from HKEY_LOCAL_MACHINE\Software Key"

End Sub

Private Sub cmdEnumKeys_Click()

Dim strvalue As String
Dim lDataLen As Long
Dim lresult As Long
Dim lValueLen As Long
Dim lCurIdx As Long
Dim lRetVal As Long
Dim hKeyResult As Long


lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "Software\Microsoft", 0, KEY_ALL_ACCESS, hKeyResult)

If lRetVal = ERROR_SUCCESS Then
lCurIdx = 0
lDataLen = 32
lValueLen = 32

Do
strvalue = String(lValueLen, 0)
lresult = RegEnumKey(hKeyResult, lCurIdx, strvalue, lDataLen)


If lresult = ERROR_SUCCESS Then
txtEnumKeys.Text = txtEnumKeys & vbCrLf & Left(strvalue, lValueLen)
End If

lCurIdx = lCurIdx + 1

Loop While lresult = ERROR_SUCCESS

RegCloseKey hKeyResult
Else
MsgBox "Cannot Open Key"
End If

End Sub

Private Sub cmdGet_Click()
Dim strTop As String
Dim strLeft As String
strLeft = GetSetting(CurrentProject.Name, "Form Location", "Left")
strTop = GetSetting(CurrentProject.Name, "Form Location", "Top")

frmRegistry.Left = CInt(strLeft)
frmRegistry.Top = CInt(strTop)

End Sub

Private Sub cmdGetAll_Click()

Dim arrAllSettings As Variant

arrAllSettings = GetAllSettings(CurrentProject.Name, "Form Location")


txtGetAllSettings.Text = arrAllSettings(0, 0) & " = " & arrAllSettings(0, 1) & vbCrLf
txtGetAllSettings.Text = txtGetAllSettings.Text & arrAllSettings(1, 0) & " = " & arrAllSettings(1, 1)

End Sub

Private Sub cmdQueryValue_Click()

QueryValue "Software\" & CurrentProject.Name, "Test"

End Sub