io Programmo 21

home *** CD-ROM | disk | FTP | other *** search

/ io Programmo 21 / IOPROG_21.ISO / SOFT / EASYREG.ZIP / Example.Frm (.txt) < prev next >

Wrap

Visual Basic Form | 1997-09-04 | 25.3 KB | 790 lines

VERSION 5.00 Begin VB.Form frmDirectory BorderStyle = 1 'Fixed Single Caption = "Registry Directory" ClientHeight = 6780 ClientLeft = 588 ClientTop = 324 ClientWidth = 8688 Icon = "Example.frx":0000 LinkTopic = "Form1" LockControls = -1 'True MaxButton = 0 'False PaletteMode = 1 'UseZOrder ScaleHeight = 6780 ScaleWidth = 8688 Begin VB.CommandButton cmdDeleteKey Caption = "Delete Key" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 492 Left = 2040 TabIndex = 29 Top = 5760 Width = 1932 End Begin VB.CommandButton cmdNewKey Caption = "New Key" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 492 Left = 120 TabIndex = 28 Top = 5760 Width = 1452 End Begin VB.CommandButton cmdDeleteValue Caption = "Delete Value" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 492 Left = 6720 TabIndex = 27 Top = 6204 Width = 1824 End Begin VB.CommandButton cmdNewValueName Caption = "New Value" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 492 Left = 4200 TabIndex = 26 Top = 5520 Width = 1452 End Begin VB.Frame fraType Caption = "Type" Height = 732 Left = 5760 TabIndex = 22 Top = 5040 Width = 2892 Begin VB.OptionButton optType Caption = "DWord" Height = 288 Index = 2 Left = 1836 TabIndex = 25 Top = 264 Value = -1 'True Width = 972 End Begin VB.OptionButton optType Caption = "Bytes" Height = 372 Index = 1 Left = 972 TabIndex = 24 Top = 216 Width = 852 End Begin VB.OptionButton optType Caption = "String" Height = 408 Index = 0 Left = 108 TabIndex = 23 Top = 204 Width = 852 End End Begin VB.CommandButton cmdSetValue Caption = "Set Value" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 492 Left = 4200 TabIndex = 21 Top = 4920 Width = 1452 End Begin VB.TextBox txtValueDbl Height = 372 Left = 5160 TabIndex = 17 Top = 4320 Width = 1452 End Begin VB.TextBox txtValueByt Height = 492 Left = 5160 MultiLine = -1 'True ScrollBars = 1 'Horizontal TabIndex = 16 Top = 3720 Width = 3372 End Begin VB.TextBox txtValueType Height = 300 Left = 5160 TabIndex = 15 Top = 2760 Width = 1452 End Begin VB.TextBox txtValueStr Height = 492 Left = 5160 MultiLine = -1 'True ScrollBars = 1 'Horizontal TabIndex = 14 Top = 3120 Width = 3372 End Begin VB.ComboBox cboValueName Height = 288 Left = 5160 Sorted = -1 'True Style = 2 'Dropdown List TabIndex = 12 Top = 2400 Width = 3372 End Begin VB.ComboBox cboKeyDirectory Height = 288 Left = 4680 Sorted = -1 'True Style = 2 'Dropdown List TabIndex = 9 Top = 1800 Width = 3864 End Begin VB.ListBox lstValueDirectory Height = 1392 ItemData = "Example.frx":0442 Left = 120 List = "Example.frx":0449 Sorted = -1 'True TabIndex = 6 Top = 4200 Width = 3852 End Begin VB.CommandButton cmdCdRoot Caption = "CD \" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 492 Left = 5760 TabIndex = 5 Top = 1200 Width = 1452 End Begin VB.CommandButton cmdCdUp Caption = "CD .." BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 492 Left = 4200 TabIndex = 4 Top = 1200 Width = 1452 End Begin VB.ListBox lstKeyDirectory Height = 1776 ItemData = "Example.frx":0460 Left = 120 List = "Example.frx":0467 Sorted = -1 'True TabIndex = 3 Top = 2040 Width = 3852 End Begin VB.CommandButton cmdDir Caption = "Dir" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 492 Left = 120 TabIndex = 2 Top = 1200 Width = 2532 End Begin VB.TextBox txtCurrentDirectory Height = 492 Left = 120 MultiLine = -1 'True ScrollBars = 1 'Horizontal TabIndex = 1 Text = "Example.frx":047C Top = 480 Width = 8412 End Begin VB.Line Line4 BorderColor = &H00E0E0E0& Index = 2 X1 = 4236 X2 = 8580 Y1 = 6108 Y2 = 6108 End Begin VB.Line Line3 Index = 2 X1 = 4236 X2 = 8580 Y1 = 6096 Y2 = 6096 End Begin VB.Line Line3 Index = 1 X1 = 4236 X2 = 8580 Y1 = 4788 Y2 = 4788 End Begin VB.Line Line4 BorderColor = &H00E0E0E0& Index = 1 X1 = 4236 X2 = 8580 Y1 = 4800 Y2 = 4800 End Begin VB.Label Label7 Caption = "Number" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Index = 2 Left = 4200 TabIndex = 20 Top = 4440 Width = 972 End Begin VB.Label Label7 Caption = "Bytes" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Index = 1 Left = 4200 TabIndex = 19 Top = 3804 Width = 732 End Begin VB.Label Label7 Caption = "String" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Index = 0 Left = 4200 TabIndex = 18 Top = 3240 Width = 732 End Begin VB.Label Label6 Caption = "Type" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Left = 4560 TabIndex = 13 Top = 2760 Width = 612 End Begin VB.Label Label5 Caption = "ValueOf" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Left = 4200 TabIndex = 11 Top = 2400 Width = 924 End Begin VB.Line Line4 BorderColor = &H00E0E0E0& Index = 0 X1 = 4212 X2 = 8556 Y1 = 2256 Y2 = 2256 End Begin VB.Line Line3 Index = 0 X1 = 4212 X2 = 8556 Y1 = 2244 Y2 = 2244 End Begin VB.Label Label4 Caption = "CD" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Left = 4200 TabIndex = 10 Top = 1800 Width = 372 End Begin VB.Line Line2 BorderColor = &H00E0E0E0& X1 = 4080 X2 = 4080 Y1 = 1236 Y2 = 6684 End Begin VB.Line Line1 X1 = 4068 X2 = 4068 Y1 = 1224 Y2 = 6684 End Begin VB.Label Label3 Caption = "Value Names" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Left = 120 TabIndex = 8 Top = 3960 Width = 2052 End Begin VB.Label Label2 Caption = "Keys" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Left = 120 TabIndex = 7 Top = 1800 Width = 852 End Begin VB.Label Label1 Caption = "Current Directory" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Left = 120 TabIndex = 0 Top = 120 Width = 2028 End Attribute VB_Name = "frmDirectory" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Const REG_SZ = 1 Const REG_BINARY = 3 Const REG_DWORD = 4 ' -- Set RO a Textbox Const WM_USER = &H400 Const EM_SETREADONLY = (WM_USER + 31) Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long Private Sub Form_Load() SendMessage txtCurrentDirectory.hwnd, EM_SETREADONLY, 1, 0 SendMessage txtValueType.hwnd, EM_SETREADONLY, 1, 0 SendMessage txtValueStr.hwnd, EM_SETREADONLY, 1, 0 SendMessage txtValueByt.hwnd, EM_SETREADONLY, 1, 0 SendMessage txtValueDbl.hwnd, EM_SETREADONLY, 1, 0 txtCurrentDirectory = "" #If Test Then Cd "\HKEY_CURRENT_USER\SOFTWARE\VB AND VBA PROGRAM SETTINGS\LM CANCELLA" txtCurrentDirectory = CurrentKey #End If cmdDir.Value = True End Sub Private Sub cmdDir_Click() Dim astrResult As Variant Dim lngJ As Long Dim strValueType As String MousePointer = vbHourglass lstKeyDirectory.Clear cboKeyDirectory.Clear lstValueDirectory.Clear cboValueName.Clear cmdSetValue.Enabled = False cmdDeleteValue.Enabled = False cmdNewValueName.Enabled = False cmdNewKey.Enabled = False cmdDeleteKey.Enabled = False txtValueType = "" txtValueStr = "" txtValueByt = "" txtValueDbl = "" If txtCurrentDirectory <> "" Then cmdNewKey.Enabled = True cmdDeleteKey.Enabled = True cmdNewValueName.Enabled = True End If astrResult = DirKey If Not IsNull(astrResult) Then For lngJ = LBound(astrResult) To UBound(astrResult) lstKeyDirectory.AddItem astrResult(lngJ) cboKeyDirectory.AddItem astrResult(lngJ) Next End If astrResult = DirValue If Not IsNull(astrResult) Then For lngJ = LBound(astrResult, 2) To UBound(astrResult, 2) Select Case astrResult(erValueType, lngJ) Case erByte strValueType = "BYTE" Case erDWord strValueType = "DWORD" Case Else strValueType = "STRING" End Select lstValueDirectory.AddItem astrResult(erValueName, lngJ) & "|(" & strValueType & ")" & "|" & astrResult(erValue, lngJ) cboValueName.AddItem astrResult(erValueName, lngJ) & "|(" & strValueType & ")" & "|" & astrResult(erValue, lngJ) Next End If MousePointer = vbDefault End Sub Private Sub lstKeyDirectory_DblClick() With lstKeyDirectory If .ListIndex <> -1 Then _ Cd .List(.ListIndex) End With txtCurrentDirectory = CurrentKey cmdDir.Value = True End Sub Private Sub cboKeyDirectory_Click() With cboKeyDirectory If .ListIndex <> -1 Then _ Cd CurrentKey & IIf(CurrentKey = "", "", "\") & .List(.ListIndex) End With txtCurrentDirectory = CurrentKey cmdDir.Value = True End Sub Private Sub cboValueName_Click() If cboValueName.ListIndex <> -1 Then _ FillValue (cboValueName.List(cboValueName.ListIndex)) End Sub Private Sub lstValueDirectory_DblClick() If lstValueDirectory.ListIndex <> -1 Then _ cboValueName.ListIndex = lstValueDirectory.ListIndex End Sub Private Sub cmdCdUp_Click() On Error GoTo cmdCdUp_Click_Err Cd ".." txtCurrentDirectory = CurrentKey cmdDir.Value = True Exit Sub cmdCdUp_Click_Err: MsgBox " Number : " & Err.Number & vbCr & _ " Source : " & Err.Source & vbCr & _ " Description : " & Err.Description, _ vbExclamation + vbOKOnly, _ "Run-Time Error" End Sub Private Sub cmdCdRoot_Click() Cd "\" txtCurrentDirectory = CurrentKey cmdDir.Value = True End Sub Private Sub cmdSetValue_Click() Dim strValueName As String Dim lngValueType As enmDataType Dim strValue As String Dim dblValue As Double Dim abytValue() As Byte Dim lngI As Long Dim lngJ As Long Dim lngIndex As Long Dim strInput As String On Error GoTo cmdSetValue_Err lngIndex = cboValueName.ListIndex strValueName = cboValueName.List(cboValueName.ListIndex) strValueName = Mid(strValueName, 1, InStr(strValueName, "|") - 1) If optType(0).Value = True Then lngValueType = erSTRING strValue = InputBox("Value Name : " & strValueName & vbCr & vbCr & _ "Insert a STRING value", "SET Value") If strValue = "" Then GoTo cmdNewValueName_Abort ValueOf(strValueName, lngValueType) = strValue ElseIf optType(1).Value = True Then lngValueType = erByte Do strInput = InputBox("How many BYTES to enter ?", "SET Value") If strInput = "" Then GoTo cmdNewValueName_Abort Loop While Not IsNumeric(strInput) lngJ = Val(strInput) For lngI = 1 To lngJ ReDim Preserve abytValue(1 To lngI) Do strInput = InputBox("Value Name : " & strValueName & vbCr & vbCr & _ "Insert BYTE value (" & lngI & "/" & lngJ & ")", "SET Value") If strInput = "" Then GoTo cmdNewValueName_Abort Loop Until IsNumeric(strInput) And Val(strInput) >= 0 And Val(strInput) <= 255 abytValue(lngI) = CByte(Int(Val(strInput))) Next ValueOf(strValueName, lngValueType) = abytValue Else lngValueType = erDWord Do strInput = InputBox("Value Name : " & strValueName & vbCr & vbCr & _ "Insert a DWORD value", "SET Value") If strInput = "" Then GoTo cmdNewValueName_Abort Loop Until IsNumeric(strInput) And Val(strInput) >= 0 And Val(strInput) <= 4294967295# dblValue = CDbl(Int(Val(strInput))) ValueOf(strValueName, lngValueType) = dblValue End If cmdDir.Value = True cboValueName.ListIndex = lngIndex Exit Sub cmdSetValue_Err: MsgBox " Number : " & Err.Number & vbCr & _ " Source : " & Err.Source & vbCr & _ " Description : " & Err.Description, _ vbExclamation + vbOKOnly, _ "Run-Time Error" Exit Sub cmdNewValueName_Abort: Beep End Sub Private Sub cmdNewValueName_Click() Dim strValueName As String Dim lngValueType As enmDataType Dim strValue As String Dim dblValue As Double Dim abytValue() As Byte Dim lngI As Long Dim lngJ As Long Dim strInput As String On Error GoTo cmdNewValueName_Err strValueName = InputBox("Insert the NAME of the value " & vbCr & _ "you want add in the Registry :", "NEW ValueName=Value") If strValueName = "" Then GoTo cmdNewValueName_Abort If optType(0).Value = True Then lngValueType = erSTRING strValue = InputBox("Value Name : " & strValueName & vbCr & vbCr & _ "Insert a STRING value", "SET Value") If strValue = "" Then GoTo cmdNewValueName_Abort ValueOf(strValueName, lngValueType) = strValue ElseIf optType(1).Value = True Then lngValueType = erByte Do strInput = InputBox("How many BYTES to enter ?", "SET Value") If strInput = "" Then GoTo cmdNewValueName_Abort Loop While Not IsNumeric(strInput) lngJ = Val(strInput) For lngI = 1 To lngJ ReDim Preserve abytValue(1 To lngI) Do strInput = InputBox("Value Name : " & strValueName & vbCr & vbCr & _ "Insert BYTE value (" & lngI & "/" & lngJ & ")", "SET Value") If strInput = "" Then GoTo cmdNewValueName_Abort Loop Until IsNumeric(strInput) And Val(strInput) >= 0 And Val(strInput) <= 255 abytValue(lngI) = CByte(Int(Val(strInput))) Next ValueOf(strValueName, lngValueType) = abytValue Else lngValueType = erDWord Do strInput = InputBox("Value Name : " & strValueName & vbCr & vbCr & _ "Insert a DWORD value", "SET Value") If strInput = "" Then GoTo cmdNewValueName_Abort Loop Until IsNumeric(strInput) And Val(strInput) >= 0 And Val(strInput) <= 4294967295# dblValue = CDbl(Int(Val(strInput))) ValueOf(strValueName, lngValueType) = dblValue End If cmdDir.Value = True Exit Sub cmdNewValueName_Err: MsgBox " Number : " & Err.Number & vbCr & _ " Source : " & Err.Source & vbCr & _ " Description : " & Err.Description, _ vbExclamation + vbOKOnly, _ "Run-Time Error" Exit Sub cmdNewValueName_Abort: Beep End Sub Private Sub cmdNewKey_Click() Dim strValueName As String strValueName = InputBox("Insert the NAME of the key " & vbCr & _ "you want add in the Registry :", "NEW KEY") If strValueName = "" Then GoTo cmdNewKey_Abort MakeKey strValueName cmdDir.Value = True Exit Sub cmdNewKey_Abort: Beep End Sub Private Sub cmdDeleteValue_Click() Dim strValueName As String strValueName = cboValueName.List(cboValueName.ListIndex) strValueName = Mid(strValueName, 1, InStr(strValueName, "|") - 1) DeleteValue strValueName cmdDir.Value = True End Sub Private Sub cmdDeleteKey_Click() Dim strKeyName As String Dim strDefault As String If lstKeyDirectory.ListIndex <> -1 Then _ strDefault = lstKeyDirectory.List(lstKeyDirectory.ListIndex) strKeyName = InputBox("Insert the NAME of the key " & vbCr & _ "you want DELETE :", "DELETE KEY", strDefault) If strKeyName = "" Then GoTo cmdDeleteKey_Abort If vbOK = MsgBox("Do you really want " & vbCr & _ "to delete KEY " & strKeyName & " ?", _ vbOKCancel Or vbQuestion, "DELETE KEY") Then DeleteKey strKeyName cmdDir.Value = True Else GoTo cmdDeleteKey_Abort End If Exit Sub cmdDeleteKey_Abort: Beep End Sub Private Sub FillValue(ByVal strValueName As String) Const REG_BINARY = 3 Const REG_DWORD = 4 Dim strNome As String Dim lngValueType As enmDataType Dim strValueType As String Dim vntByte As Variant Dim dblValue As Double Dim vntReturn As Variant Dim lngI As Long txtValueType = "" txtValueStr = "" txtValueByt = "" txtValueDbl = "" vntReturn = ValueOf(Mid(strValueName, 1, InStr(strValueName, "|") - 1), lngValueType) txtValueStr = vntReturn(0) Select Case lngValueType Case erByte optType(1).Value = True strValueType = "BYTE" Case erDWord strValueType = "DWORD" optType(2).Value = True Case Else strValueType = "STRING" optType(0).Value = True End Select txtValueType = strValueType vntByte = vntReturn(1) For lngI = LBound(vntByte) To UBound(vntByte) txtValueByt = txtValueByt & vntByte(lngI) & " " Next txtValueDbl = vntReturn(2) cmdSetValue.Enabled = True cmdDeleteValue.Enabled = True End Sub