کار با رجیستری بدون مشکل

[mmssoft]

سلام. من توی برنامم نیاز به استفاده از رجیستری دارم. کارهایی که لازم دارم انجام بشن : 1- ایجاد مسیر 2- ساخت StringValue و ذخیره یک مقدار در اون 3- فراخوانی StringValue

توی سایت مطالب زیادی بود و هر کدوم یه سری مشکلات داشتن، بعضی از ماژول ها اصلن کار نمیکرد، بعضی ها روی ویندوز 64 بیت مشکل داشت، یه ماژول هم که خودم دارم توی حالت Design ویژوال بیسیک درست کار میکنه ، ولی وقتی برنامه رو exe میکنم، مقدارها رو فراخوانی کنه!!!!!!!!

درخواستم اینه که اگه کسی ماژول یا کلاسی جامعی در این زمینه سراغ داره بذاره تا دیگه همه کاربران از اون استفاده کنند...

ممنون

[m.4.r.m]

از این کامپوننت استفاده کن

[mmssoft]

ممنون، خیلی عالـی بود...
من سعی میکنم تو برنامم کمتر از OCX استفاده بشه، واسه این کار کلاس یا ماژولی سراغ ندارید؟

[m.4.r.m]

Option Explicit

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const REG_SZ = 1 ' Unicode nul terminated string
Public Const REG_BINARY = 3 ' Free form binary
Public Const REG_DWORD = 4 ' 32-bit number
Public Const ERROR_SUCCESS = 0&

Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
'--------------------------------------------------
Public 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
Public Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
'--------------------------------------------------
Public 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
Public 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

Public Sub CreateKey(hKey As Long, strPath As String)
Dim hCurKey As Long
Dim lRegResult As Long

lRegResult = RegCreateKey(hKey, strPath, hCurKey)

If lRegResult <> ERROR_SUCCESS Then
' there is a problem
End If

lRegResult = RegCloseKey(hCurKey)

End Sub

Public Sub DeleteKey(ByVal hKey As Long, ByVal strPath As String)
Dim lRegResult As Long

lRegResult = RegDeleteKey(hKey, strPath)

End Sub

Public Sub DeleteValue(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String)
Dim hCurKey As Long
Dim lRegResult As Long

lRegResult = RegOpenKey(hKey, strPath, hCurKey)

lRegResult = RegDeleteValue(hCurKey, strValue)

lRegResult = RegCloseKey(hCurKey)

End Sub

Public Function GetSettingString(hKey As Long, strPath As String, strValue As String, Optional Default As String) As String
Dim hCurKey As Long
Dim lValueType As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim intZeroPos As Integer
Dim lRegResult As Long

' Set up default value
If Not IsEmpty(Default) Then
GetSettingString = Default
Else
GetSettingString = ""
End If

' Open the key and get length of string
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, ByVal 0&, lDataBufferSize)

If lRegResult = ERROR_SUCCESS Then

If lValueType = REG_SZ Then
' initialise string buffer and retrieve string
strBuffer = String(lDataBufferSize, " ")
lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, 0&, ByVal strBuffer, lDataBufferSize)

' format string
intZeroPos = InStr(strBuffer, Chr$(0))
If intZeroPos > 0 Then
GetSettingString = Left$(strBuffer, intZeroPos - 1)
Else
GetSettingString = strBuffer
End If

End If

Else
' there is a problem
End If

lRegResult = RegCloseKey(hCurKey)
End Function

Public Sub SaveSettingString(hKey As Long, strPath As String, strValue As String, strData As String)
Dim hCurKey As Long
Dim lRegResult As Long

lRegResult = RegCreateKey(hKey, strPath, hCurKey)

lRegResult = RegSetValueEx(hCurKey, strValue, 0, REG_SZ, ByVal strData, Len(strData))

If lRegResult <> ERROR_SUCCESS Then
'there is a problem
End If

lRegResult = RegCloseKey(hCurKey)
End Sub

Public Function GetSettingLong(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String, Optional Default As Long) As Long

Dim lRegResult As Long
Dim lValueType As Long
Dim lBuffer As Long
Dim lDataBufferSize As Long
Dim hCurKey As Long

' Set up default value
If Not IsEmpty(Default) Then
GetSettingLong = Default
Else
GetSettingLong = 0
End If

lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lDataBufferSize = 4 ' 4 bytes = 32 bits = long

lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, lBuffer, lDataBufferSize)

If lRegResult = ERROR_SUCCESS Then

If lValueType = REG_DWORD Then
GetSettingLong = lBuffer
End If

Else
'there is a problem
End If

lRegResult = RegCloseKey(hCurKey)

End Function

Public Sub SaveSettingLong(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String, ByVal lData As Long)
Dim hCurKey As Long
Dim lRegResult As Long

lRegResult = RegCreateKey(hKey, strPath, hCurKey)

lRegResult = RegSetValueEx(hCurKey, strValue, 0&, REG_DWORD, lData, 4)

If lRegResult <> ERROR_SUCCESS Then
'there is a problem
End If

lRegResult = RegCloseKey(hCurKey)
End Sub

Public Function GetSettingByte(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, Optional Default As Variant) As Variant
Dim lValueType As Long
Dim byBuffer() As Byte
Dim lDataBufferSize As Long
Dim lRegResult As Long
Dim hCurKey As Long

' setup default value
If Not IsEmpty(Default) Then
If VarType(Default) = vbArray + vbByte Then
GetSettingByte = Default
Else
GetSettingByte = 0
End If

Else
GetSettingByte = 0
End If

' Open the key and get number of bytes
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, lValueType, ByVal 0&, lDataBufferSize)

If lRegResult = ERROR_SUCCESS Then

If lValueType = REG_BINARY Then

' initialise buffers and retrieve value
ReDim byBuffer(lDataBufferSize - 1) As Byte
lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, lValueType, byBuffer(0), lDataBufferSize)

GetSettingByte = byBuffer

End If

Else
'there is a problem
End If

lRegResult = RegCloseKey(hCurKey)

End Function

Public Sub SaveSettingByte(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, byData() As Byte)
' Make sure that the array starts with element 0 before passing it!
' (otherwise it will not be saved!)

Dim lRegResult As Long
Dim hCurKey As Long

lRegResult = RegCreateKey(hKey, strPath, hCurKey)

' Pass the first array element and length of array
lRegResult = RegSetValueEx(hCurKey, strValueName, 0&, REG_BINARY, byData(0), UBound(byData()) + 1)

lRegResult = RegCloseKey(hCurKey)

End Sub

Public Function GetAllKeys(hKey As Long, strPath As String) As Variant
' Returns: an array in a variant of strings

Dim lRegResult As Long
Dim lCounter As Long
Dim hCurKey As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim strNames() As String
Dim intZeroPos As Integer

lCounter = 0

lRegResult = RegOpenKey(hKey, strPath, hCurKey)

Do

'initialise buffers (longest possible length=255)
lDataBufferSize = 255
strBuffer = String(lDataBufferSize, " ")
lRegResult = RegEnumKey(hCurKey, lCounter, strBuffer, lDataBufferSize)

If lRegResult = ERROR_SUCCESS Then

'tidy up string and save it
ReDim Preserve strNames(lCounter) As String

intZeroPos = InStr(strBuffer, Chr$(0))
If intZeroPos > 0 Then
strNames(UBound(strNames)) = Left$(strBuffer, intZeroPos - 1)
Else
strNames(UBound(strNames)) = strBuffer
End If

lCounter = lCounter + 1

Else
Exit Do
End If
Loop

GetAllKeys = strNames
End Function

Public Function GetAllValues(hKey As Long, strPath As String) As Variant
' Returns: a 2D array.
' (x,0) is value name
' (x,1) is value type (see constants)

Dim lRegResult As Long
Dim hCurKey As Long
Dim lValueNameSize As Long
Dim strValueName As String
Dim lCounter As Long
Dim byDataBuffer(4000) As Byte
Dim lDataBufferSize As Long
Dim lValueType As Long
Dim strNames() As String
Dim lTypes() As Long
Dim intZeroPos As Integer

lRegResult = RegOpenKey(hKey, strPath, hCurKey)

Do
' Initialise bufffers
lValueNameSize = 255
strValueName = String$(lValueNameSize, " ")
lDataBufferSize = 4000

lRegResult = RegEnumValue(hCurKey, lCounter, strValueName, lValueNameSize, 0&, lValueType, byDataBuffer(0), lDataBufferSize)

If lRegResult = ERROR_SUCCESS Then

' Save the type
ReDim Preserve strNames(lCounter) As String
ReDim Preserve lTypes(lCounter) As Long
lTypes(UBound(lTypes)) = lValueType

'Tidy up string and save it
intZeroPos = InStr(strValueName, Chr$(0))
If intZeroPos > 0 Then
strNames(UBound(strNames)) = Left$(strValueName, intZeroPos - 1)
Else
strNames(UBound(strNames)) = strValueName
End If

lCounter = lCounter + 1

Else
Exit Do
End If
Loop

'Move data into array
Dim Finisheddata() As Variant
ReDim Finisheddata(UBound(strNames), 0 To 1) As Variant

For lCounter = 0 To UBound(strNames)
Finisheddata(lCounter, 0) = strNames(lCounter)
Finisheddata(lCounter, 1) = lTypes(lCounter)
Next

GetAllValues = Finisheddata

End Function

[mmssoft]

مرسی
لطفا یه مثال برای کار با GetSettingString و SaveSettingString بزنید. من که هر چی مینویسم Run-time Error 13 میده!!!!!

[ho3ein.3ven]

سلام . با استفاده از تکه کد زیر می توانید در رجیستری مقدار جدیدی بنویسید :
Dim ObReg As Object
Dim StrKeyAdress As String
Dim StrValueType As String
Dim StrValue As String

Set ObReg = CreateObject("wscript.shell")

StrValue = "00000000"
StrValueType = "REG_DWORD"
StrKeyAdress = "HKEY_CURRENT_USER\Software\Microsoft\Windows\Curre ntVersion\Policies\explorer\NoFolderOptions"
ObReg.RegWrite StrKeyAdress, StrValue, StrValueType


موفق باشید

[mmssoft]

مرسی دوست عزیز؛ ولی من میخواستم Value از نوع String باشه...

با استفاده از از تابع SaveSettingString و GetSettingString تو ماژول بالا میشه این کار رو انجام داد ولی نمیدونم این hKey که از نوع Long هست چیه!!!

اگه یه مثال بزنید ممنون میشم

[ho3ein.3ven]

آدرس کلید موجود در رجیستری هست دیگه :متفکر:

[mmssoft]

از نوع Long هست مگه میشه آدرس باشه؟؟ خوب شما مثال بزن...

[ho3ein.3ven]

من که long نمی بینم . میشه بگین کجا نوشته ؟

[mmssoft]

من که long نمی بینم . میشه بگین کجا نوشته ؟


Public Function GetSettingString(hKey As Long, strPath As String, strValue As String, Optional Default As String) As String
Public Sub SaveSettingString(hKey As Long, strPath As String, strValue As String, strData As String)

[amin32]

اگه به بالای کد توجه کنید میبینید که ثوابت مربوط به hkey تعریف شده . باید از یکی از اونها به عنوان پارامتر استفاده کنید.


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

[mmssoft]

از این کامپوننت استفاده کن

این کامپوننت یه مشکل داره که واسه مقدار های String وقتی میخواد فراخوانی کنه (با دستور Reg1.GetValue) کاراکتر آخر رو نشون نمیده!!!! توی بقیه موارد درسته!!

[mmssoft]

اگه به بالای کد توجه کنید میبینید که ثوابت مربوط به hkey تعریف شده . باید از یکی از اونها به عنوان پارامتر استفاده کنید.


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


مرسی دوست عزیز، دقت نکرده بودم
یه سوال، به نظرتون این ماژول واسه 32 بیت و 64 بیت کامل درست کار میکنه؟؟

[mmssoft]

الان تست کردم، روی ویندوزهای 64 بیت اصلا کار نمیکنه، همه مقدارها رو خالی نشون میده و نمیتونه تو Value چیزی ذخیره کنه!!!!!!

[R2du-soft]

سلام دوستان من به یه مشکلی خودم
میخوام مقداری که در یک string وجود داره رو توی یک تکست باکس نشون بدم، اما چون مسیر این string خیلی خیلی طولانی هست،هنگام خودندن ارور میده! برای ویندوز 64 بیت هم هست.
میشه راهنماییم کنید؟

میخوام از این برنامه روی ویندوز 64 بیت استفاده کنم

مسیر:

HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432node\Volatile\x ore\Interface\{00020401-0000-0000-C000-000000000046}\OLEViewerIViewerCLSID\version

[R2du-soft]

از این برای خواندن ریجستری های بلد و برای ویندوزهای 64 استفاده کنید عالی هست :لبخند:


Private Function Registry_Read(Key_Path, Key_Name) As Variant

On Error Resume Next

Dim Registry As Object

Set Registry = CreateObject("WScript.Shell")

Registry_Read = Registry.RegRead(Key_Path & Key_Name)

End Function



Private Sub Command1_Click()
Text1.Text = Registry_Read("HKEY_LOCAL_MACHINE\SOFTWARE\WOW6432Node\.......... ..", "InstallDir")
End Sub

[R2du-soft]

آقا منم دقیقا همین مشکلو دارم،چطوری میشه در ویندوز 64 بیت یه کلید اضافه کرد؟ به خدا اضافه نمیشه!

[mmssoft]

آقا منم دقیقا همین مشکلو دارم،چطوری میشه در ویندوز 64 بیت یه کلید اضافه کرد؟ به خدا اضافه نمیشه!

منم واسه همین این تاپیک رو زدم... من روش تشخیص ویندوز 64 بیت و 32 بیت رو بلدم؛ فقط میخوام یه کد واسه اضافه کردن و خوندن string value واسه 64 بیت باشه که رو هم جمع و جورش میکنم و یه ماژول کامل آماده میکنم که دیگه هیچکی مشکلی نداشته باشه!!!!

[R2du-soft]

ممنون عزیز،میشه روش تشخیص 32 یا 64 بیت بودن رو بگید؟
دقیقا من به دلیل کارنکردن Reg add در ویندوز 64 بیت مجبور شدم تا اون پستی که شما دارید کمکم میکنید رو بزنم و کلی گیر کردم تو همش!

[mmssoft]

ممنون عزیز،میشه روش تشخیص ا=32 یا 64 بیت بودن رو بگید؟
دقیقا من به دلیل کارنکردن Reg add در ویندوز 64 بیت مجبور شدم تا اون پستی که شما دارید کمکم میکنید رو بزنم و کلی گیر کردم تو همش!

بفرمایید دوست عزیز ...

[mmssoft]

مشکل رو برای خودم حل کردم، امیدوارم برای شما هم کارساز باشه :

- ویژگی ها :


این روش برای خواندن و نوشتن داده های String، Binary و DWORD و همچنین حذف کردن این نوع Valueها، کاربرد داره
توی هر دو نسخه 64 بیت و 32 بیت (تا جایی که من تست کردم) کار میکنه
از کتابخانه Windows Script Host Object Model یا همون wshom.ocx استفاده میکنه



- استفاده :




از منوی Project و قسمت References، کتابخانه Windows Script Host Object Model رو به پروژه تون اضافه کنید
برای استفاده از کتابخانه، کد زیر رو در قسمت General کپی کنید :

Private Registry As New WshShell




روش خواندن اطلاعات :

Registry.RegRead ("ROOT_KEY\SUB_KEY\...\{ValueName})"
مثال : Registry.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\mozilla.org\Mozilla\Cu rrentVersion")




روش نوشتن اطلاعات :

Registry.RegWrite "ROOT_KEY\SUB_KEY\...\{ValueName}", "Data", [DataType]
مثال : Registry.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\mozilla.org\Mozilla\Cu rrentVersion", "23"


بخش [DataType] اختیاری هست که باید توی اون نوع داده رو مشخص کنید




روش حذف مقدار :

Registry.RegDelete ("ROOT_KEY\SUB_KEY\...\{ValueName}")
مثال : Registry.RegDelete ("HKEY_LOCAL_MACHINE\SOFTWARE\mozilla.org\Mozilla\Cu rrentVersion")

[R2du-soft]

ممنون داداشی اما مگه نباید توی ویندوز 64 بیتی مسیر اینطوری باشه؟

HKEY_LOCAL_MACHINE\SOFTWARE\WOW6432Node\yahoo\vers ion\cls