Visual Basic 6.0 - Кавычки

Все равно я это не выговорю.



Это не русское слово, и я не хочу бездумно потратить часть жизни, чтобы изучать слова, само произношение которых противоречит здравому смыслу.



* Origin: Attackie Interactive (2:5045/44.13)


Мы где-то виделись, Mihail?






ReGet или Registry? ;)

Если второе - могу поделиться своим чудо-классом. ;)

Всего хорошего!
Дмитрий Козырев aka Master

* Origin: Дорогу осилит идущий. (2:5023/11.148)


Мы где-то виделись, Michail?






Возможно. Смотри MSDN на тему хуков (Hooks). Только не уверен, что это можно
будет легко реализовать на эхотаге.



А это смотря для чего тебе надо. Если ты ловишь _конкретные_ сочетания клавиш
(хоткей) - смотри в сторону RegisterHotkey.

Всего хорошего!
Дмитрий Козырев aka Master

* Origin: Дорогу осилит идущий. (2:5023/11.148)


Мы где-то виделись, Vlad?








Во-первых, это было бы не очень красиво, а во-вторых, Label (неоконный
контрол) просто не может располагаться на форме поверх оконного контрола,
которым является FG.

Всего хорошего!
Дмитрий Козырев aka Master

* Origin: Дорогу осилит идущий. (2:5023/11.148)


Мы где-то виделись, Roman?





Hифига подобного. Байт с даблом оно глотает и не морщится.



Кон-ка-те-на-ция. Hе можешь выговорить это слово - говори "слияние".





Variant? А разве не String?

Всего хорошего!
Дмитрий Козырев aka Master

P.S. А насчет стилистических предпочтений я согласен с Сергеем.

* Origin: Дорогу осилит идущий. (2:5023/11.148)


Мы где-то виделись, Mihail?









Дэржи.

============================== Смотри ниже ===============================
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "RegKey"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'///////////////////////////////////////////////////////////////////////
'// Класс для работы с реестром //
'// Copyright (c) 2002 Дмитрий Козырев //
'// mailto:abcc [@] rambler.ru //
'// Версия 1.0.11 //
'// //
'// NB: Желательно, чтобы все ключи реестра, открываемые в процессе //
'// работы программы, имели предком (не обязательно родителем) один и //
'// тот же класс; т.е. нужно описать в модуле //
'// Public Reg As New RegKey //
'// и больше объектов RegKey самостоятельно не создавать. //
'///////////////////////////////////////////////////////////////////////
Option Explicit
Option Compare Text
Option Base 0

'/////////////////////////////// Public ////////////////////////////////

Public Enum RootKeys
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_CURRENT_CONFIG = &H80000005
HKEY_DYN_DATA = &H80000006
End Enum

Public Enum ValueType
REG_NONE = 0 ' Hет типа
REG_SZ = 1 ' Строка
REG_EXPAND_SZ = 2 ' Строка + expand
REG_BINARY = 3 ' Бинарные данные
REG_DWORD = 4 ' 32-битное число
REG_DWORD_BIG_ENDIAN = 5 ' 32-битное число (big endian, unix)
REG_LINK = 6 ' Symbolic Link (юникод)
REG_MULTI_SZ = 7 ' Множество строк (юникод?)
REG_RESOURCE_LIST = 8 ' Список ресурсов (?)
End Enum

Public Enum RegVarType
vtString = vbString
vtByte = vbByte
vtBoolean = vbBoolean
vtInteger = vbInteger
vtLong = vbLong
vtSingle = vbSingle
vtDouble = vbDouble
vtDate = vbDate
vtCurrency = vbCurrency
vtExpandString = 265
vtStringAsBinary = 266
End Enum

'//////////////////////////////// Local ////////////////////////////////

Private hKey As Long
Private mPath As String
Private mRootKey As Long
Private mNT As Boolean
Private mValues() As String
Private mSubKeys() As String
Private mCreated As Boolean
Private mRegsCol As Collection

Private Type RegValueInfo
Type As Long
Size As Long
End Type

'//////////////////////////////// API //////////////////////////////////

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long)
As
Long
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias
"RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As
Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long,
lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long,
lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As
FILETIME) As Long

' ANSI: Windows 9x, ME
Private Declare Function RegCreateKeyExA Lib "advapi32.dll" (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
Private Declare Function RegDeleteKeyA Lib "advapi32.dll" (ByVal hKey As Long,
ByVal lpSubKey As String) As Long
Private Declare Function RegOpenKeyExA Lib "advapi32.dll" (ByVal hKey As Long,
ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long,
phkResult As Long) As Long
Private Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal hKey As
Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long,
lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueExA Lib "advapi32.dll" (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 RegDeleteValueA Lib "advapi32.dll" (ByVal hKey As
Long,
ByVal lpValueName As String) As Long
Private Declare Function RegEnumKeyExA Lib "advapi32.dll" (ByVal hKey As Long,
ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal
lpReserved As Long, ByVal lpClass As String, lpcbClass As Long,
lpftLastWriteTime As Any) As Long
Private Declare Function RegEnumValueA Lib "advapi32.dll" (ByVal hKey As Long,
ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long,
ByVal
lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function ExpandEnvironmentStringsA Lib "kernel32" (ByVal lpSrc
As String, ByVal lpDst As String, ByVal nSize As Long) As Long

' Unicode: Windows NT, 2K, XP
Private Declare Function RegCreateKeyExW Lib "advapi32.dll" (ByVal hKey As
Long,
ByVal lpSubKey As Long, ByVal Reserved As Long, ByVal lpClass As Long, ByVal
dwOPtions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As
Long,
phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegDeleteKeyW Lib "advapi32.dll" (ByVal hKey As Long,
ByVal lpSubKey As Long) As Long
Private Declare Function RegOpenKeyExW Lib "advapi32.dll" (ByVal hKey As Long,
ByVal lpSubKey As Long, ByVal ulOptions As Long, ByVal samDesired As Long,
phkResult As Long) As Long
Private Declare Function RegQueryValueExW Lib "advapi32.dll" (ByVal hKey As
Long, ByVal lpValueName As Long, ByVal lpReserved As Long, lpType As Long,
lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueExW Lib "advapi32.dll" (ByVal hKey As
Long,
ByVal lpValueName As Long, ByVal Reserved As Long, ByVal dwType As Long,
lpData
As Any, ByVal cbData As Long) As Long
Private Declare Function RegDeleteValueW Lib "advapi32.dll" (ByVal hKey As
Long,
ByVal lpValueName As Long) As Long
Private Declare Function RegEnumKeyExW Lib "advapi32.dll" (ByVal hKey As Long,
ByVal dwIndex As Long, ByVal lpName As Long, lpcbName As Long, ByVal
lpReserved
As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any)
As Long
Private Declare Function RegEnumValueW Lib "advapi32.dll" (ByVal hKey As Long,
ByVal dwIndex As Long, ByVal lpValueName As Long, lpcbValueName As Long, ByVal
lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function ExpandEnvironmentStringsW Lib "kernel32" (ByVal lpSrc
As Long, ByVal lpDst As Long, ByVal nSize As Long) As Long

Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
(Destination As Any, Source As Any, ByVal Length As Long) As Long

Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As
FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As
FILETIME, lpLocalFileTime As FILETIME) As Long

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA"
(lpVersionInformation As OSVERSIONINFO) As Long


Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type


Const REG_OPTION_NON_VOLATILE = 0 ' Key is preserved when system is
rebooted
Const REG_OPTION_VOLATILE = 1 ' Key is not preserved when system is
rebooted

Const REG_OPENED_EXISTING_KEY = &H2 ' Existing Key opened
Const REG_CREATED_NEW_KEY = &H1 ' New Registry Key created

Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const STANDARD_RIGHTS_ALL = &H1F0000
Const SYNCHRONIZE = &H100000
Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or
KEY_SET_VALUE
Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or
KEY_CREATE_LINK) And (Not SYNCHRONIZE))

Const ERROR_SUCCESS = 0& ' Все Ok
Const ERROR_MORE_DATA = 234& ' Есть еще данные
Const ERROR_NO_MORE_ITEMS = 259& ' Все, больше элементов нет

Const VER_PLATFORM_WIN32_WINDOWS = 1
Const VER_PLATFORM_WIN32_NT = 2

'///////////////////////////////////////////////////////////////////////
'// DeleteSubKey - удаляет подключ открытого ключа. //
'// Для NT - рекурсивная функция. //
'// //
'// SubKeyName - имя удаляемого подключа. //
'///////////////////////////////////////////////////////////////////////
Public Sub DeleteSubKey(ByVal SubKeyName As String)
If Closed Then Exit Sub
If mNT Then
pDeleteKey hKey, mPath, SubKeyName
Else
Dim lKey As RegKey
Set lKey = pGetKeyObject(pTrimSlash(mPath & "\" & SubKeyName), mRootKey)
If Not lKey Is Nothing Then
lKey.frInit vbNullString, 0, Nothing
End If

RegDeleteKey hKey, SubKeyName
End If
End Sub

'///////////////////////////////////////////////////////////////////////
'// DeleteMe - закрывает открытый ключ и удаляет его. //
'// Для NT - рекурсивная функция. //
'///////////////////////////////////////////////////////////////////////
Public Sub DeleteMe()
If Closed Then Exit Sub
If mNT Then
RegCloseKey hKey: hKey = 0
pDeleteKey mRootKey, vbNullString, mPath
Else
RegCloseKey hKey: hKey = 0
RegDeleteKey mRootKey, mPath
frInit vbNullString, 0, Nothing
End If
End Sub

'///////////////////////////////////////////////////////////////////////
'// DeleteValue - удаляет значение из открытого ключа. //
'// //
'// ValueName - имя удаляемого значения. //
'///////////////////////////////////////////////////////////////////////
Public Sub DeleteValue(ByVal ValueName As String)
If Closed Then Exit Sub
RegDeleteValue hKey, ValueName
End Sub

'///////////////////////////////////////////////////////////////////////
'// GetRootKey - возвращает объект с открытым корневым ключом. //
'// //
'// RootKey - ключ; если опущен, возвращается ключ, соответствующий //
'// текущему открытому ключу. //
'///////////////////////////////////////////////////////////////////////
Public Property Get GetRootKey(Optional ByVal RootKey As RootKeys) As RegKey
If RootKey = 0 Then RootKey = mRootKey
Set GetRootKey = pGetKeyObject("", RootKey, True)
End Property

Private Sub pDeleteKey(ByVal hKey As Long, ByVal Path As String, ByVal
SubKeyName As String)
Dim lKey&, lKeys() As String, i&
If RegOpenKeyEx(hKey, SubKeyName, KEY_ALL_ACCESS, lKey) = ERROR_SUCCESS Then
pEnumSubKeys lKey, lKeys
For i = 1 To UBound(lKeys)
pDeleteKey lKey, Path & "\" & SubKeyName, lKeys(i)
Next i
RegCloseKey lKey

Dim lRKey As RegKey
Set lRKey = pGetKeyObject(pTrimSlash(Path & "\" & SubKeyName), mRootKey)
If Not lRKey Is Nothing Then
lRKey.frInit vbNullString, 0, Nothing
End If

RegDeleteKey hKey, SubKeyName
End If
End Sub

Private Sub pEnumSubKeys(ByVal hKey As Long, SubKeys() As String)
Dim lName$, lLen&, Res&
ReDim SubKeys(0)
lName = String$(256, 0)
Do
lLen = Len(lName)
Res = RegEnumKeyEx(hKey, UBound(SubKeys), lName, lLen)
If Res = ERROR_SUCCESS Then
ReDim Preserve SubKeys(UBound(SubKeys) + 1)
SubKeys(UBound(SubKeys)) = Left$(lName, lLen)
Else
Exit Sub
End If
Loop
End Sub

Private Sub pEnumValues(ByVal hKey As Long, mValues() As String)
Dim lName$, lLen&, Res&
ReDim mValues(0)
lName = String$(256, 0)
Do
lLen = Len(lName)
Res = RegEnumValue(hKey, UBound(mValues), lName, lLen)
If Res = ERROR_SUCCESS Then
ReDim Preserve mValues(UBound(mValues) + 1)
mValues(UBound(mValues)) = Left$(lName, lLen)
Else
Exit Sub
End If
Loop
End Sub

Private Function pTrimSlash(ByVal s As String) As String
If Left$(s, 1) = "\" Then s = Mid$(s, 2)
If Right$(s, 1) = "\" Then s = Left$(s, Len(s) - 1)
If Len(s) = 0 Then s = "\"
pTrimSlash = s
End Function

Private Function RegCreateKeyEx(ByVal hKey As Long, ByVal lpSubKey As String,
ByVal dwOPtions As Long, ByVal samDesired As Long, phkResult As Long,
lpdwDisposition As Long) As Long
If mNT Then
RegCreateKeyEx = RegCreateKeyExW(hKey, StrPtr(lpSubKey), 0, 0, dwOPtions,
samDesired, 0, phkResult, lpdwDisposition)
Else
RegCreateKeyEx = RegCreateKeyExA(hKey, lpSubKey, 0, vbNullString,
dwOPtions,
samDesired, 0, phkResult, lpdwDisposition)
End If
End Function

Private Function RegDeleteKey(ByVal hKey As Long, ByVal lpSubKey As String) As
Long
If mNT Then
RegDeleteKey = RegDeleteKeyW(hKey, StrPtr(lpSubKey))
Else
RegDeleteKey = RegDeleteKeyA(hKey, lpSubKey)
End If
End Function

Private Function RegDeleteValue(ByVal hKey As Long, ByVal lpValueName As
String)
As Long
If mNT Then
RegDeleteValue = RegDeleteValueW(hKey, StrPtr(lpValueName))
Else
RegDeleteValue = RegDeleteValueA(hKey, lpValueName)
End If
End Function

Private Function ExpandEnvironmentStrings(ByVal Src As String, Dest As String,
ByVal nSize As Long) As Long
If mNT Then
ExpandEnvironmentStrings = ExpandEnvironmentStringsW(StrPtr(Src),
StrPtr(Dest), nSize)
Else
ExpandEnvironmentStrings = ExpandEnvironmentStringsA(Src, Dest, nSize)
End If
End Function

Private Function RegOpenKeyEx(ByVal hKey As Long, ByVal lpSubKey As String,
ByVal samDesired As Long, phkResult As Long) As Long
If mNT Then
RegOpenKeyEx = RegOpenKeyExW(hKey, StrPtr(lpSubKey), 0, samDesired,
phkResult)
Else
RegOpenKeyEx = RegOpenKeyExA(hKey, lpSubKey, 0, samDesired, phkResult)
End If
End Function

Private Function RegQueryValueEx(ByVal hKey As Long, ByVal lpValueName As
String, lpType As Long, ByVal lpDataPtr As Long, lpcbData As Long) As Long
If mNT Then
RegQueryValueEx = RegQueryValueExW(hKey, StrPtr(lpValueName), 0, lpType,
ByVal lpDataPtr, lpcbData)
Else
RegQueryValueEx = RegQueryValueExA(hKey, lpValueName, 0, lpType, ByVal
lpDataPtr, lpcbData)
End If
End Function

Private Function RegSetValueEx(ByVal hKey As Long, lpValueName As String,
ByVal
dwType As Long, ByVal lpDataPtr As Long, ByVal cbData As Long) As Long
If mNT Then
RegSetValueEx = RegSetValueExW(hKey, StrPtr(lpValueName), 0, dwType, ByVal
lpDataPtr, cbData)
Else
RegSetValueEx = RegSetValueExA(hKey, lpValueName, 0, dwType, ByVal
lpDataPtr, cbData)
End If
End Function

Private Function RegEnumValue(ByVal hKey As Long, ByVal Index As Long,
ValueName
As String, lpValueSize As Long) As Long
If mNT Then
RegEnumValue = RegEnumValueW(hKey, Index, StrPtr(ValueName), lpValueSize,
0,
ByVal 0&, ByVal 0&, ByVal 0&)
Else
RegEnumValue = RegEnumValueA(hKey, Index, ValueName, lpValueSize, 0, ByVal
0&, ByVal 0&, ByVal 0&)
End If
End Function

Private Function RegEnumKeyEx(ByVal hKey As Long, ByVal Index As Long,
ValueName
As String, lpValueSize As Long) As Long
If mNT Then
RegEnumKeyEx = RegEnumKeyExW(hKey, Index, StrPtr(ValueName), lpValueSize,
0,
vbNullString, ByVal 0&, ByVal 0&)
Else
RegEnumKeyEx = RegEnumKeyExA(hKey, Index, ValueName, lpValueSize, 0,
vbNullString, ByVal 0&, ByVal 0&)
End If
End Function

'///////////////////////////////////////////////////////////////////////
'// Closed - определяет, закрыт ли текущий ключ. //
'///////////////////////////////////////////////////////////////////////
Public Property Get Closed() As Boolean
Closed = (hKey = 0)
End Property

'///////////////////////////////////////////////////////////////////////
'// EnumChildValues - перебирает все значения открытого ключа. //
'///////////////////////////////////////////////////////////////////////
Public Sub EnumChildValues()
If Closed Then Exit Sub

pEnumValues hKey, mValues
End Sub

'///////////////////////////////////////////////////////////////////////
'// EnumSubKeys - перебирает все подключи. //
'///////////////////////////////////////////////////////////////////////
Public Sub EnumSubKeys()
If Closed Then Exit Sub

pEnumSubKeys hKey, mSubKeys
End Sub

Friend Sub frInit(ByVal Path As String, ByVal RootKey As RootKeys, RegCol As
Collection, Optional ByVal CreateIfDoesNotExists As Boolean = True)
Dim i&
If Not RegCol Is Nothing Then Set mRegsCol = RegCol

On Error Resume Next
mRegsCol.Add ObjPtr(Me), CStr(ObjPtr(Me))
Err.Clear
On Error GoTo 0


RegCloseKey hKey
hKey = 0
mPath = vbNullString
End If


Dim Res&
If Path = "\" Then Path = vbNullString
Res = RegOpenKeyEx(RootKey, Path, KEY_ALL_ACCESS, hKey)
If Res = ERROR_SUCCESS Then
mPath = Path
mRootKey = RootKey
mCreated = False
Else
If CreateIfDoesNotExists Then
Dim Disp&, lKeys, lKey&, rhKey&
lKeys = Split(Path, "\")
lKey = RootKey
For i = LBound(lKeys) To UBound(lKeys)
Res = RegCreateKeyEx(lKey, lKeys(i), REG_OPTION_NON_VOLATILE,
_
KEY_ALL_ACCESS, rhKey, Disp)
If Res = ERROR_SUCCESS Then
mCreated = (Disp = REG_CREATED_NEW_KEY)
lKey = rhKey
If i = UBound(lKeys) Then ' all ok
mPath = Path
mRootKey = RootKey
End If
Else
hKey = 0
lKey = 0
Exit For
End If
Next i
hKey = lKey
End If
End If
Else
mPath = vbNullString
hKey = 0
End If
End Sub

'///////////////////////////////////////////////////////////////////////
'// LastModified - возвращает дату последнего изменения ключа. //
'// Только для NT! //
'///////////////////////////////////////////////////////////////////////
Public Property Get LastModified() As Date
If Closed Then Exit Sub
If mNT Then LastModified = pKeyTime(hKey)
End Property

Private Function pKeyTime(ByVal hKey As Long) As Date
Dim lFT As FILETIME, lST As SYSTEMTIME
If RegQueryInfoKey(hKey, vbNullString, ByVal 0&, 0, _
ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, _
ByVal 0&, ByVal 0&, lFT) = ERROR_SUCCESS Then

FileTimeToLocalFileTime lFT, lFT
FileTimeToSystemTime lFT, lST
pKeyTime = DateSerial(lST.wYear, lST.wMonth, lST.wDay) + _
TimeSerial(lST.wHour, lST.wMinute, lST.wSecond)
End If
End Function

'///////////////////////////////////////////////////////////////////////
'// SubKeyLastModified - возвращает дату последнего изменения //
'// подключа. Только для NT! //
'///////////////////////////////////////////////////////////////////////
Public Property Get SubKeyLastModified(ByVal SubKeyName As String) As Date
Dim rhKey&, Res&
If Closed Then Exit Sub

If mNT Then
Res = RegOpenKeyEx(hKey, SubKeyName, KEY_ALL_ACCESS, rhKey)

SubKeyLastModified = pKeyTime(rhKey)
RegCloseKey rhKey
End If
End If
End Property

'///////////////////////////////////////////////////////////////////////
'// OpenKey - открывает ключ и возвращает объект, соответствующий ему.//
'// //
'// Path - путь к ключу; //
'// AbsolutePath - абсолютный или относительный путь; //
'// RootKey - корневой ключ; //
'// CreateIfDoesNotExists - создавать ключ, если он не существует; //
'// InThisObject - открывать ключ в текущем объекте (если существует //
'// другой объект с таким ключом, он закрывается). //
'///////////////////////////////////////////////////////////////////////
Public Function OpenKey(ByVal Path As String, Optional ByVal AbsolutePath As
Boolean = False, Optional ByVal RootKey As RootKeys = 0, Optional ByVal
CreateIfDoesNotExists As Boolean = True, Optional ByVal InThisObject As
Boolean
= False) As RegKey
Dim lPath$, lRoot&, lObj As RegKey
Path = pTrimSlash(Path)
If AbsolutePath Then
lPath = Path
Else
lPath = mPath & "\" & Path
End If
lPath = pTrimSlash(lPath)


lRoot = RootKey
Else
lRoot = mRootKey
End If

Set lObj = pGetKeyObject(lPath, lRoot)
Dim lExists As Boolean
lExists = Not lObj Is Nothing

If InThisObject Then
If Not lObj Is Nothing Then
lObj.frInit vbNullString, 0, Nothing
End If
Set lObj = Me
lExists = False
Else
If lObj Is Nothing Then Set lObj = New RegKey
End If

If Not lExists Then
lObj.frInit lPath, lRoot, mRegsCol, CreateIfDoesNotExists
End If
Set OpenKey = lObj
End Function

'///////////////////////////////////////////////////////////////////////
'// Parent - возвращает ключ-родитель для данного ключа. //
'///////////////////////////////////////////////////////////////////////
Public Property Get Parent() As RegKey
If Closed Then Exit Property
If Len(Path) = 0 Then Exit Property

Dim lPath$, lPos&
lPos = InStrRev(mPath, "\")
If lPos = 0 Then
lPath = "\"
Else
lPath = Left$(mPath, lPos - 1)
End If

Set Parent = pGetKeyObject(mPath, mRootKey, True)
End Property

'///////////////////////////////////////////////////////////////////////
'// Path - возвращает путь к открытому ключу. //
'///////////////////////////////////////////////////////////////////////
Public Property Get Path() As String
Path = mPath
End Property

Private Function pGetKeyObject(ByVal Path As String, ByVal RootKey As
RootKeys,
Optional ByVal AddIfDoesNotExists As Boolean = False) As RegKey
Dim lPos&, i&, o As Object

For i = 1 To mRegsCol.Count
CopyMemory o, CLng(mRegsCol(i)), 4
Set pGetKeyObject = o
CopyMemory o, 0&, 4
If pGetKeyObject.Path = Path And pGetKeyObject.RootKey = RootKey Then
Exit For
End If
Set pGetKeyObject = Nothing
Next i

If pGetKeyObject Is Nothing And AddIfDoesNotExists Then
Set pGetKeyObject = New RegKey
pGetKeyObject.frInit Path, RootKey, mRegsCol
End If
End Function

'///////////////////////////////////////////////////////////////////////
'// RootKey - возвращает корневой ключ. //
'///////////////////////////////////////////////////////////////////////
Public Property Get RootKey() As RootKeys
RootKey = mRootKey
End Property

Public Property Let RootKey(ByVal vData As RootKeys)
If Closed Then
mRootKey = vData
End If
End Property

'///////////////////////////////////////////////////////////////////////
'// SubKey - возвращает подключ по номеру. //
'// Перед этим требуется вызвать EnumSubKeys. //
'///////////////////////////////////////////////////////////////////////
Public Property Get SubKey(ByVal Index As Long) As String
If Closed Then Exit Sub


SubKey = mSubKeys(Index)
End If
End Property

'///////////////////////////////////////////////////////////////////////
'// SubKeysExists - проверяет существование подключа по его имени. //
'///////////////////////////////////////////////////////////////////////
Public Property Get SubKeyExists(ByVal SubKeyName As String) As Boolean
Dim rhKey&, Res&
If Closed Then Exit Sub

Res = RegOpenKeyEx(hKey, SubKeyName, KEY_ALL_ACCESS, rhKey)

SubKeyExists = (Res = ERROR_SUCCESS)
End Property

'///////////////////////////////////////////////////////////////////////
'// SubKeysCount - возвращает количество подключей. //
'// Перед этим требуется вызвать EnumSubKeys. //
'///////////////////////////////////////////////////////////////////////
Public Property Get SubKeysCount() As Long
If Closed Then Exit Sub

SubKeysCount = UBound(mSubKeys)
End Property

'///////////////////////////////////////////////////////////////////////
'// ChildValue - возвращает имя значения по номеру. //
'// Перед этим требуется вызвать EnumChildValues. //
'///////////////////////////////////////////////////////////////////////
Public Property Get ChildValue(ByVal Index As Long) As String
If Closed Then Exit Sub


ChildValue = mValues(Index)
End If
End Property

'///////////////////////////////////////////////////////////////////////
'// ChildValuesCount - возвращает количество значений. //
'// Перед этим требуется вызвать EnumChildValues. //
'///////////////////////////////////////////////////////////////////////
Public Property Get ChildValuesCount() As Long
If Closed Then Exit Sub

ChildValuesCount = UBound(mValues)
End Property

'///////////////////////////////////////////////////////////////////////
'// ValueExists - проверяет наличие значения по его имени. //
'///////////////////////////////////////////////////////////////////////
Public Property Get ValueExists(ByVal ValueName As String) As Boolean
Dim lInfo As RegValueInfo
If Closed Then Exit Sub

ValueExists = pGetValueInfo(hKey, ValueName, lInfo)
End Property

'///////////////////////////////////////////////////////////////////////
'// ValueType - возвращает тип данных значения. //
'///////////////////////////////////////////////////////////////////////
Public Property Get ValueType(ByVal ValueName As String) As ValueType
Dim lInfo As RegValueInfo
If Closed Then Exit Sub

pGetValueInfo hKey, ValueName, lInfo
ValueType = lInfo.Type
End Property

Private Function pGetValueInfo(ByVal hKey As Long, ByVal ValueName As String,
Info As RegValueInfo) As Boolean
Dim Res&, ValType&, ValSize&
Res = RegQueryValueEx(hKey, ValueName, ValType, 0, ValSize)
If Res = ERROR_SUCCESS Then
Info.Type = ValType
Info.Size = ValSize
pGetValueInfo = True
Else
pGetValueInfo = False
End If
End Function

'///////////////////////////////////////////////////////////////////////
'// Value - возвращает значение. //
'// //
'// ValueName - имя значения; //
'// VarType - тип возвращаемых данных (все элементы перечисления, //
'// кроме vtExpandString, соответствуют аналогичным значениям //
'// перечисления vbVarType). //
'///////////////////////////////////////////////////////////////////////
Public Property Get Value(Optional ByVal ValueName As String, Optional ByVal
VarType As RegVarType) As Variant
Attribute Value.VB_UserMemId = 0
Dim lInfo As RegValueInfo, b() As Byte
If Closed Then Exit Property

If Not pGetValueInfo(hKey, ValueName, lInfo) Then Exit Property
Select Case lInfo.Type
Case REG_BINARY, REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ, REG_DWORD
ReDim b(IIf(lInfo.Size = 0, 0, lInfo.Size - 1))
RegQueryValueEx hKey, ValueName, 0&, VarPtr(b(0)), CLng(lInfo.Size)
Case Else
Exit Property
End Select

Select Case lInfo.Type
Case REG_SZ, REG_MULTI_SZ
VarType = vtString
Case REG_EXPAND_SZ
VarType = vtExpandString
Case REG_DWORD
Select Case VarType
Case vtByte, vtInteger, vtBoolean, vtLong
Case Else
VarType = vtLong
End Select
End Select

If VarType = vtByte And (lInfo.Size = 1 Or lInfo.Type = REG_DWORD) Then
Dim lByte As Byte
CopyMemory lByte, b(0), 1
Value = lByte
ElseIf (VarType = vtInteger Or VarType = vtBoolean) And (lInfo.Size = 2 Or
lInfo.Type = REG_DWORD) Then
Dim lInt As Integer
CopyMemory lInt, b(0), 2
If VarType = vbBoolean Then Value = CBool(lInt) Else Value = lInt
ElseIf VarType = vtLong And (lInfo.Size = 4 Or lInfo.Type = REG_DWORD) Then
Dim lLong&
CopyMemory lLong, b(0), 4
Value = lLong
ElseIf VarType = vtSingle And lInfo.Size = 4 Then
Dim lSng!
CopyMemory lSng, b(0), 4
Value = lSng
ElseIf (VarType = vtDouble Or VarType = vtDate) And lInfo.Size = 8 Then
Dim lDbl#
CopyMemory lDbl, b(0), 8
If VarType = vtDate Then Value = CDate(lDbl) Else Value = lDbl
ElseIf VarType = vtCurrency And lInfo.Size = 8 Then
Dim lCur [@]
CopyMemory lCur, b(0), 8
Value = lCur
Else
Dim lStr$, lDest$

lStr = b
If (Not mNT) Or lInfo.Type = REG_BINARY Then lStr = StrConv(lStr,
vbUnicode)
End If
If lInfo.Type = REG_EXPAND_SZ Then
lDest = lStr & lStr
lDest = Left$(lDest, ExpandEnvironmentStrings(lStr, lDest,
Len(lDest)))
Else
lDest = lStr
End If

' Dim lPos&
' lPos = InStr(lDest, vbNullChar)

' End If
Value = lDest
End If
End Property

'///////////////////////////////////////////////////////////////////////
'// Value - устанавливает значение. //
'// //
'// ValueName - имя значения; //
'// VarType - не используется. //
'///////////////////////////////////////////////////////////////////////
Public Property Let Value(Optional ByVal ValueName As String, Optional ByVal
VarType As RegVarType, NewValue As Variant)
Dim lInfo As RegValueInfo, b() As Byte
If Closed Then Exit Property

ReDim b(7)
Select Case VBA.VarType(NewValue)
Case vbByte, vbInteger, vbBoolean, vbLong
CopyMemory b(0), CLng(NewValue), 4
lInfo.Size = 4
lInfo.Type = REG_DWORD
Case vbSingle
CopyMemory b(0), CSng(NewValue), 4
lInfo.Size = 4
lInfo.Type = REG_BINARY
Case vbDouble, vbDate
CopyMemory b(0), CDbl(NewValue), 8
lInfo.Size = 8
lInfo.Type = REG_BINARY
Case vbCurrency
CopyMemory b(0), CDbl(NewValue), 8
lInfo.Size = 8
lInfo.Type = REG_BINARY
Case vbString
Dim s$
s = NewValue

If mNT Then
b = s
lInfo.Size = Len(s) * 2
Else
ReDim b(Len(s))
CopyMemory b(0), ByVal s, Len(s)
lInfo.Size = Len(s)
End If
End If
If VarType = vtExpandString Then
lInfo.Type = REG_EXPAND_SZ
ElseIf VarType = vtStringAsBinary Then
lInfo.Type = REG_BINARY
Else
lInfo.Type = REG_SZ
End If
End Select

RegSetValueEx hKey, ValueName, lInfo.Type, VarPtr(b(0)), lInfo.Size
End Property

Private Sub Class_Initialize()
hKey = 0
mRootKey = HKEY_CURRENT_USER

Dim osvi As OSVERSIONINFO
osvi.dwOSVersionInfoSize = Len(osvi)
GetVersionEx osvi
mNT = (osvi.dwPlatformId = VER_PLATFORM_WIN32_NT)

Set mRegsCol = New Collection
End Sub

Private Sub Class_Terminate()

RegCloseKey hKey
hKey = 0
End If

If Not mRegsCol Is Nothing Then
On Error Resume Next
mRegsCol.Remove CStr(ObjPtr(Me))
End If
End Sub
============================== Смотри выше ===============================

Всего хорошего!
Дмитрий Козырев aka Master

* Origin: Дорогу осилит идущий. (2:5023/11.148)









Учи великий могучий, особенно по части пофигов ;)









Hа то ты и программист, чтобы следить за типами, у меня тип вариант встречается 1 раз на 1000 переменных. Для пары чисел, причем с частым преобразованием лучше (и грамотнее) c = cstr(a) + " долларов в час" чем с = a & " долларов в час". А вообще - дела вкуса, но так, как я написал - правильнее. ;)



В трех переменных заблудился? :)





?



* Origin: Attackie Interactive (2:5045/44.13)




Hello, Dmitriy!

2003 17:08:02 +0300:


В словаре написано "сцепление", это имхо корректнее.


With best regards, A. Skrobov. E-mail: tyomitch [@] r66.ru
--
* Origin: Talk.Mail.Ru (2:5020/400)




Hello, Roman!
You wrote to Sergey Broudkov on Mon, 27 Oct 2003 22:30:53 +0300:







Я бы хотел вообще его не использовать, но иногда приходится.





Правильнее написать c = CStr(a) & "долларов в час"




Я не заблудился, я иллюстрировал возможную проблему.

--
Regards,
Sergey Broudkov
sbpro [@] geocities.com
ICQ #4841919
А может, в реестре чего подправить? d;--D

* Origin: Demos online service (2:5020/400)




Hello, Sergey!
You wrote to Roman Yuakovlev on Mon, 27 Oct 2003 17:17:22 +0000 (UTC):







Снимаю свое заявление, Alexander Trishin меня переубедил.

--
Regards,
Sergey Broudkov
sbpro [@] geocities.com
ICQ #4841919
А может, в реестре чего подправить? d;--D

* Origin: Demos online service (2:5020/400)