Option Explicit

Const SYNCHRONIZE = &H100000
Const INFINITE = &HFFFF
Const WAIT_OBJECT_0 = 0
Const WAIT_TIMEOUT = &H102

Dim stopflag As Boolean
Dim errorflag As Boolean

Dim mindelay As Integer
Dim maxdelay As Integer
Dim totaldelay As Long
Dim avgdelay As Integer
Dim lcount As Long
Dim pingMessage(26) As String
Dim ctrl
Private Declare Function SendMessage Lib “User32″ Alias “SendMessageA” (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function OpenProcess Lib “kernel32″ (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib “kernel32″ (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib “kernel32″ (ByVal hObject As Long) As Long

Private Sub cmdClear_Click()
    Open “C:\log.txt” For Output As #1
    Close #1
    txtoutput.Text = “”
    txtpinglog.Text = “”
End Sub

Private Sub cmdExit_Click()
    Unload Me
    End
End Sub

Private Sub cmdlog_Click()
    Load frmlog
    frmlog.Show 1
End Sub

Private Sub cmdPing_Click()
DoEvents
If cmdPing.Caption = “Ping” Then
    lblstatus.Caption = “Pinging ” & txtIP.Text & ” with ” & txtbuffer.Text & “KB of data”
    txtIP.Locked = True
    cmdPing.BackColor = &HFF&
   cmdlog.Enabled = False
    cmdPing.Caption = “Stop”
    stopflag = False
Else
    stopflag = True
   cmdPing.Caption = “Ping”
   txtIP.Locked = False
   cmdPing.BackColor = &H80FF80
   cmdlog.Enabled = True
   lblstatus.Caption = “Stopped”
End If
   
While stopflag = False
  DoEvents
        
    Dim ShellX As String
    Dim lPid As Long
    Dim lHnd As Long
    Dim lRet As Long
    Dim VarX As String
    Dim Ptime As Integer
    Dim pttl As Integer
    Dim pbyte As Integer
    Dim i As Integer
    Dim pingresult As String
    Dim tmin As Integer
    Dim tmax As Integer
    Dim tavg As Integer
   
      If txtIP.Text <> “” Then
        DoEvents
        ShellX = Shell(”command.com /c ping -n 1 -l ” & txtbuffer.Text & ” ” & txtIP.Text & ” > C:\log.txt”, vbHide)
        lPid = ShellX
        If lPid <> 0 Then
            lHnd = OpenProcess(SYNCHRONIZE, 0, lPid)
            If lHnd <> 0 Then
                lRet = WaitForSingleObject(lHnd, INFINITE)
                CloseHandle (lHnd)
            End If
               
                frmmain.MousePointer = 0
                Open “C:\log.txt” For Input As #1
                txtoutput.Text = Input(LOF(1), 1)
               
                pingresult = Trim(Mid(txtoutput.Text, InStr(1, txtoutput.Text, “:”) + 1, Len(txtoutput.Text) - (InStr(1, txtoutput.Text, “:”) + Len(Mid(txtoutput.Text, InStr(1, txtoutput.Text, “Ping “))))))
               
                ‘check for error
                If InStr(1, pingresult, “Reply”) = 0 Then
                     Dim message As String
                    If InStr(1, pingresult, “Hardware”) <> 0 Then
                              message = “HARDWARE FAULT”
                         Else
                            If InStr(1, pingresult, “Request”) <> 0 Then
                              message = “Request time out”
                         Else
                              If InStr(1, pingresult, “Destination”) <> 0 Then
                                   message = “Destination Computer is not reachable”
                              Else
                                   message = pingresult
                                End If
                       
                        End If
                    End If
                   pingresult = “ERROR with ” & txtIP.Text & “:” & message
                          
                 
                   ‘pingmessage
                  txtpinglog.Text = “”
                  For i = 0 To 22
                        pingMessage(i) = pingMessage(i + 1)
                       If pingMessage(i + 1) <> “” Then
                                If txtpinglog.Text <> “” Then
                                    txtpinglog.Text = txtpinglog.Text & vbCrLf
                                End If
                                    txtpinglog.Text = txtpinglog.Text & pingMessage(i + 1)
                        End If
                   Next
                  
                   pingMessage(23) = pingresult
                   If txtpinglog.Text <> “” Then
                                txtpinglog.Text = txtpinglog.Text & vbCrLf
                    End If
                   txtpinglog.Text = txtpinglog.Text & pingresult

                      For i = 0 To 31
                            pbrtime(i).Value = pbrtime(i + 1).Value
                         Next
                         pbrtime(32).Value = 0
                        
                       
                        
                         ‘loging
                            If chklog.Value = 1 Then
                                If errorflag = False Then
                                    errorflag = True
                                        Open “c:\pinglog.txt” For Append As #2
                                            Print #2, Now
                                            Print #2, pingresult
                                            Print #2, String(91, “*”)
                                        Close #2
                                End If
                            End If
                               lcount = 0
                               mindelay = 0
                               maxdelay = 0
                               avgdelay = 0
                               totaldelay = 0
                              
                                lblmin = mindelay
                                lblmax = maxdelay
                                lblavg = avgdelay
                        
                 Else
                   lcount = lcount + 1
                    Ptime = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, “time”) + 5, InStr(1, txtoutput.Text, “ms “) - InStr(1, txtoutput.Text, “time”) - 5))
                    pbyte = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, “bytes=”) + 6, InStr(1, txtoutput.Text, ” time”) - InStr(1, txtoutput.Text, “bytes=”) - 6))
                    pttl = CInt(Mid(pingresult, InStr(1, pingresult, “TTL=”) + 4, Len(pingresult) - InStr(1, pingresult, “TTL=”) - 5))
                   
                    tmin = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, “Minimum = “) + 10, InStr(InStr(1, txtoutput.Text, “Minimum = “), txtoutput.Text, “ms,”) - InStr(1, txtoutput.Text, “Minimum = “) - 10))
                    tmax = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, “Maximum = “) + 10, InStr(InStr(1, txtoutput.Text, “Maximum = “), txtoutput.Text, “ms,”) - InStr(1, txtoutput.Text, “Maximum = “) - 10))
                    tavg = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, “Average = “) + 10, InStr(InStr(1, txtoutput.Text, “Average = “), txtoutput.Text, “ms”) - InStr(1, txtoutput.Text, “Average = “) - 10))
                   
                    If mindelay = 0 Then mindelay = tmin
                   
                    If tmin < mindelay Then
                        mindelay = tmin
                    End If
                    If tmax > maxdelay Then
                        maxdelay = tmax
                    End If
                    totaldelay = totaldelay + tavg
                    avgdelay = CInt(totaldelay / lcount)
                   
                    lblmin = mindelay
                    lblmax = maxdelay
                    lblavg = avgdelay
                   
                If avgdelay > 0 Then
                    For Each ctrl In frmmain
                        If TypeOf ctrl Is ProgressBar Then
                            ctrl.Max = avgdelay * 10
                        End If
                    Next
                End If
                       
                   
                   
                pingresult = “Reply from ” & txtIP.Text & “: bytes=” & pbyte & ” time=” & Ptime & “ms TTL=” & pttl
                txtpinglog.Text = “”
                  For i = 0 To 22
                        pingMessage(i) = pingMessage(i + 1)
                        If pingMessage(i + 1) <> “” Then
                            If txtpinglog.Text <> “” Then
                                txtpinglog.Text = txtpinglog.Text & vbCrLf
                            End If
                            txtpinglog.Text = txtpinglog.Text & pingMessage(i + 1)
                        End If
                   Next
                   pingMessage(23) = pingresult
                    If txtpinglog.Text <> “” Then
                        txtpinglog.Text = txtpinglog.Text & vbCrLf
                    End If
                   txtpinglog.Text = txtpinglog.Text & pingresult
                                 
                      
                      
                       ‘loging
                        If chklog.Value = 1 Then
                                If errorflag = True Then
                                    errorflag = False
                                        Open “c:\pinglog.txt” For Append As #2
                                            Print #2, Now
                                            Print #2, “Reconnected with ” & txtIP.Text
                                            Print #2, String(91, “*”)
                                        Close #2
                                End If
                            End If
                           
                           
                         On Error Resume Next
                            Ptime = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, “time=”) + 5, InStr(1, txtoutput.Text, “ms “) - InStr(1, txtoutput.Text, “time=”) - 5))
                         For i = 0 To 31
                            pbrtime(i).Value = pbrtime(i + 1).Value
                         Next
                         pbrtime(32).Value = Ptime
                    
                End If
                       Close #1
        End If
      Else
        frmmain.MousePointer = 0
        VarX = MsgBox(”You have not entered an ip address or the number of times you want to ping.”, vbCritical, “Error has occured”)
      End If
Wend
End Sub

Private Sub Command1_Click()
Load frmAbout
frmAbout.Show 1
End Sub

Private Sub Form_Load()

errorflag = False
totaldelay = 0
mindelay = 0
maxdelay = 0
avgdelay = 0
lcount = 0
  Open “C:\log.txt” For Output As #1
  Close #1
End Sub

Private Sub SelectText(ByRef textObj As RichTextBox)
    textObj.SelStart = 0
    textObj.SelLength = Len(textObj)
End Sub

Private Sub Label6_Click()

End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

Private Sub Label2_Click()

End Sub

Private Sub Slider1_Change()
Select Case Slider1.Value
Case 0: txtbuffer.Text = 32
Case 1: txtbuffer.Text = 320
Case 2: txtbuffer.Text = 3200
Case 3: txtbuffer.Text = 32000

End Select
       
        lcount = 0
        mindelay = 0
        maxdelay = 0
        avgdelay = 0
        totaldelay = 0
       
         lblmin = mindelay
         lblmax = maxdelay
         lblavg = avgdelay
       
End Sub

Private Sub Timer1_Timer()
End Sub

Private Sub txtIP_GotFocus()
    Call SelectText(txtIP)
End Sub
Private Sub txtOutput_GotFocus()
‘    Call SelectText(txtoutput)
End Sub

Private Sub txtStatus_Click()
    txtIP.SetFocus
End Sub

Public Function IsGroupMember(Username As String, _
DomainName As String, _
GroupName As String) As Boolean
‘=================================================
‘=================================================
‘   Purpose:    To determin if a user is a member of a specified group
‘
‘   Syntax:     IsGroupMember(User Name, Domain Name, Group Name)
‘
‘   Arguments:
‘               username        — login ID of user to verify
‘               DomainName      — Domain name the user and group reside in
‘                (Can also use IP Address of Primary Domain Controller)
‘               GroupName       — NT Group name to match the user to
‘
‘   Example:    IsGroupMember(”myusername”, “mydomain”, “mygroupname”)
‘==========================================================
‘==========================================================
Dim usr As IADsUser, obj As Object, sOut() As String, i As Long
IsGroupMember = False
Set usr = GetObject(”WinNT://” & DomainName & “/” & Username & “,user”)
For Each obj In usr.Groups
If GroupName = obj.Name Then IsGroupMember = True
Next
End Function

Function IsGoodPWD(sUserName As String, DomainName As String, _
chkPassword As String) As Boolean
‘====================================================
‘=====================================================
‘   Purpose:    To determin if a password given is the correct network password for the specified user
‘
‘   Syntax:     IsGoodPWD(User Name, Domain Name, Password)
‘
‘   Arguments:
‘               username        — login ID of user to verify
‘               DomainName      — Domain name the user and group reside in
‘                           (Can also use IP Address of Primary Domain Controller)
‘               chkPassword     — Password to verify against the domain
‘
‘   Example:    IsGoodPWD(”myusername”, “mydomain”, “mypass123″)
‘==============================================================
‘=========================================================
On Error GoTo MyError:
Dim usr As IADsUser
Set usr = GetObject(”WinNT://” & DomainName & “/” & sUserName & “,user”)
usr.ChangePassword chkPassword, “qinspwue4″
usr.ChangePassword “qinspwue4″, chkPassword
IsGoodPWD = True
Exit Function
MyError:
IsGoodPWD = False
End Function

Public Function ShowGroupMembers(DomainName As String, _
UserGroupName As String)
‘=========================================================
‘=========================================================
‘   Purpose:    To display the members of a specified user group
‘
‘   Syntax:     ShowGroupMembers(Domain Name, User Group Name)
‘
‘   Arguments:
‘               DomainName      — Domain name the user and group reside in
‘                            (Can also use IP Address of Primary Domain Controller)
‘               UserGroupName   — The name of the NT User Group
‘
‘   Example:    Call ShowGroupMembers(”mydomain”, “mygroupname”)
‘============================================================
‘============================================================
Dim grp As IADsGroup, User As Object
Set grp = GetObject(”WinNT://” & DomainName & “/” & UserGroupName & “”)
For Each User In grp.members
Debug.Print User.Name
Next User
End Function

Private Sub cmdShowFileSize_Click()
Dim strOldFile As String
Dim strOldSize As String
Dim strMyDir As String
Dim strMyFile As String

strMyDir = “c:\windows\desktop”
strMyFile = “readme.txt”

strOldFile = strMyDir & “\” & strMyFile
strOldSize = FileLen(strOldFile)

lblFileSize.Caption = “The file ” & strOldFile & ” is ” & _
Format(strOldSize, “#,##0″) & ” bytes in size.”

End Sub

‘5 picture boxs, 1 timer, 2 labels and 1 button

Option Explicit
Private Declare Function BitBlt Lib “gdi32″ (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Const SRCCOPY = &HCC0020
Const SRCAND = &H8800C6
Const SRCPAINT = &HEE0086
Dim SpriteX& ‘ dim a long variable to hold the current X position on the Cave Dude sprite

Private Sub Command1_Click()

If Not Timer1.Enabled Then      ‘ jika timer mati
Timer1.Enabled = True       ‘ fungsi timer aktif
Command1.Caption = “Stop!”   ‘ tombol command berubah ->’STOP’
Else
Timer1.Enabled = False      ‘ jika timer hidup
Command1.Caption = “Go!”     ‘ tombol command berubah ->’Lanjut’
End If

End Sub

Private Sub Form_Load()

Dim ReturnResult& ‘dim a long variable to hold the return value BitBlt will pass
SpriteX& = 512 ‘ set the starting X coordinate for the Cave Dude sprite
ReturnResult& = BitBlt(picOldDisplay.hDC, 0, 0, 64, 64, picDisplay.hDC, SpriteX&, 64, SRCCOPY) ‘ copy a “clean” area from the display to be repainted when the loops comes around again to get rid of the old player X blit

End Sub

Private Sub Timer1_Timer()

Static AnimationCount& ‘ dim a long variable to hold which animation frame we are on, and make it static, so it retains its’ value between procedures
Dim ReturnResult& ‘dim a long variable to hold the return value BitBlt will pass

ReturnResult = BitBlt(picDisplay.hDC, SpriteX&, 64, 64, 64, picOldDisplay.hDC, 0, 0, SRCCOPY) ‘ copy the clean part of the display back over the old sprite X
SpriteX& = SpriteX& - 5 ‘the cave dude walks from right to left, so he starts out at a positive X location, and we decrement his location every loops by 5 pixels
ReturnResult = BitBlt(picOldDisplay.hDC, 0, 0, 64, 64, picDisplay.hDC, SpriteX&, 64, SRCCOPY) ‘ copy a “clean” area from the display to be repainted when the loops comes around again to get rid of the old player X blit
picOldDisplay.Refresh ‘ refresh the old display to reflect changes (this is only done to show what the contents of this picturebox look like. Normally this picturebox would not be visible to the player)
ReturnResult& = BitBlt(picWorkArea.hDC, 0, 0, 64, 64, picOldDisplay.hDC, 0, 0, SRCCOPY) ‘ copy the area the sprite will be blitted to into the work area
ReturnResult& = BitBlt(picWorkArea.hDC, 0, 0, 64, 64, picCaveDudeMask.hDC, AnimationCount&, 0, SRCAND) ‘ SRCAND the sprite mask on top of the display section we copied
ReturnResult& = BitBlt(picWorkArea.hDC, 0, 0, 64, 64, picCaveDude.hDC, AnimationCount&, 0, SRCPAINT) ‘ SRCPAINT the sprite on top of the mask and the display section
picWorkArea.Refresh ‘ refresh the work area to reflect changes(this is only done to show what the contents of this picturebox look like. Normally this picturebox would not be visible to the player)
ReturnResult& = BitBlt(picDisplay.hDC, SpriteX&, 64, 64, 64, picWorkArea.hDC, 0, 0, SRCCOPY) ‘ SRCCOPY the completed display section with transparent sprite back into the display picturebox
picDisplay.Refresh ‘ refresh the display to reflect the changes

If SpriteX& < -64 Then  ‘ if the Cave Dude walks off the screen completely, reset the program, and start him walking again
SpriteX& = 512
AnimationCount& = 0
picOldDisplay.Cls
picWorkArea.Cls
ReturnResult& = BitBlt(picOldDisplay.hDC, 0, 0, 64, 64, picDisplay.hDC, SpriteX&, 64, SRCCOPY) ‘ copy a “clean” area from the display to be repainted when the loops comes around again to get rid of the old player X blit
End If

AnimationCount& = AnimationCount& + 64 ‘ increment the animation by one frame

If AnimationCount& = 512 Then AnimationCount& = 0 ‘ if the AnimationCount is equal to the number of animation frames we have, reset the frame count to 0 to start over

End Sub

Dim FrameCount As Long

Private Sub Command1_Click()
Timer1.Enabled = False
If LoadGif(Text1, Image1) Then
FrameCount = 0
Timer1.Interval = CLng(Image1(0).Tag)
Timer1.Enabled = True
End If
End Sub

Private Sub Command2_Click()
Timer1.Enabled = False
End Sub

Private Sub Command3_Click()
Timer1.Enabled = True
End Sub

Private Sub Form_Load()

Text1.Text = App.Path & IIf(Right(App.Path, 1) = “\”, “”, “\”) & “clip.gif”
Timer1.Enabled = False
End Sub

Private Sub Timer1_Timer()
If FrameCount < TotalFrames Then
Image1(FrameCount).Visible = False
FrameCount = FrameCount + 1
Image1(FrameCount).Visible = True
Timer1.Interval = CLng(Image1(FrameCount).Tag)
Else
FrameCount = 0
For i = 1 To Image1.Count - 1
Image1(i).Visible = False
Next i
Image1(FrameCount).Visible = True
Timer1.Interval = CLng(Image1(FrameCount).Tag)
End If
End Sub

00000000000000000000000000000000000000000
:  Welcome www.programmervb.wordpress.com :
00000000000000000000000000000000000000000

‘Add 8 CommandButtons, 1 Timer, 2 Labels and 1 TextBox
‘Play Music With CD
‘Form

Option Explicit

Dim fastForwardSpeed As Long    ‘ seconds to seek for ff/rew
Dim fPlaying As Boolean         ‘ true if CD is currently playing
Dim fCDLoaded As Boolean        ‘ true if CD is the the player
Dim numTracks As Integer        ‘ number of tracks on audio CD
Dim trackLength() As String     ‘ array containing length of each track
Dim track As Integer            ‘ current track
Dim min As Integer              ‘ current minute on track
Dim sec As Integer              ‘ current second on track
Dim cmd As String               ‘ string to hold mci command strings

‘ Send a MCI command string
‘ If fShowError is true, display a message box on error
Private Function SendMCIString(cmd As String, fShowError As Boolean) As Boolean
Static rc As Long
Static errStr As String * 200

rc = mciSendString(cmd, 0, 0, hWnd)
If (fShowError And rc <> 0) Then
mciGetErrorString rc, errStr, Len(errStr)
MsgBox errStr
End If
SendMCIString = (rc = 0)
End Function

Private Sub Form_Load()

‘ If we’re already running, then quit
If (App.PrevInstance = True) Then
End
End If

‘ Initialize variables
Timer1.Enabled = False
fastForwardSpeed = 5
fCDLoaded = False

‘ If the cd is being used, then quit
If (SendMCIString(”open cdaudio alias cd wait shareable”, True) = False) Then
End
End If

SendMCIString “set cd time format tmsf wait”, True
Timer1.Enabled = True

End Sub

Private Sub Form_Unload(Cancel As Integer)
‘Close all MCI devices opened by this program
SendMCIString “close all”, False
End Sub

‘ Play the CD
Private Sub play_Click()
SendMCIString “play cd”, True
fPlaying = True
End Sub
‘ Stop the CD play
Private Sub stopbtn_Click()
SendMCIString “stop cd wait”, True
cmd = “seek cd to ” & track
SendMCIString cmd, True
fPlaying = False
Update
End Sub
‘ Pause the CD
Private Sub pause_Click()
SendMCIString “pause cd”, True
fPlaying = False
Update
End Sub
‘ Eject the CD
Private Sub eject_Click()
SendMCIString “set cd door open”, True
Update
End Sub
‘ Fast forward
Private Sub ff_Click()
Dim s As String * 40

SendMCIString “set cd time format milliseconds”, True
mciSendString “status cd position wait”, s, Len(s), 0
If (fPlaying) Then
cmd = “play cd from ” & CStr(CLng(s) + fastForwardSpeed * 1000)
Else
cmd = “seek cd to ” & CStr(CLng(s) + fastForwardSpeed * 1000)
End If
mciSendString cmd, 0, 0, 0
SendMCIString “set cd time format tmsf”, True
Update
End Sub
‘ Rewind the CD
Private Sub rew_Click()
Dim s As String * 40

SendMCIString “set cd time format milliseconds”, True
mciSendString “status cd position wait”, s, Len(s), 0
If (fPlaying) Then
cmd = “play cd from ” & CStr(CLng(s) - fastForwardSpeed * 1000)
Else
cmd = “seek cd to ” & CStr(CLng(s) - fastForwardSpeed * 1000)
End If
mciSendString cmd, 0, 0, 0
SendMCIString “set cd time format tmsf”, True
Update
End Sub
‘ Forward track
Private Sub ftrack_Click()
If (track < numTracks) Then
If (fPlaying) Then
cmd = “play cd from ” & track + 1
SendMCIString cmd, True
Else
cmd = “seek cd to ” & track + 1
SendMCIString cmd, True
End If
Else
SendMCIString “seek cd to 1″, True
End If
Update
End Sub
‘ Go to previous track
Private Sub btrack_Click()
Dim from As String
If (min = 0 And sec = 0) Then
If (track > 1) Then
from = CStr(track - 1)
Else
from = CStr(numTracks)
End If
Else
from = CStr(track)
End If
If (fPlaying) Then
cmd = “play cd from ” & from
SendMCIString cmd, True
Else
cmd = “seek cd to ” & from
SendMCIString cmd, True
End If
Update
End Sub
‘ Update the display and state variables
Private Sub Update()
Static s As String * 30

‘ Check if CD is in the player
mciSendString “status cd media present”, s, Len(s), 0
If (CBool(s)) Then
‘ Enable all the controls, get CD information
If (fCDLoaded = False) Then
mciSendString “status cd number of tracks wait”, s, Len(s), 0
numTracks = CInt(Mid$(s, 1, 2))
eject.Enabled = True

‘ If CD only has 1 track, then it’s probably a data CD
If (numTracks = 1) Then
Exit Sub
End If

mciSendString “status cd length wait”, s, Len(s), 0
totalplay.Caption = “Tracks: ” & numTracks & “  Total time: ” & s
ReDim trackLength(1 To numTracks)
Dim i As Integer
For i = 1 To numTracks
cmd = “status cd length track ” & i
mciSendString cmd, s, Len(s), 0
trackLength(i) = s
Next
play.Enabled = True
pause.Enabled = True
ff.Enabled = True
rew.Enabled = True
ftrack.Enabled = True
btrack.Enabled = True
stopbtn.Enabled = True
fCDLoaded = True
SendMCIString “seek cd to 1″, True
End If

‘ Update the track time display
mciSendString “status cd position”, s, Len(s), 0
track = CInt(Mid$(s, 1, 2))
min = CInt(Mid$(s, 4, 2))
sec = CInt(Mid$(s, 7, 2))
timeWindow.Text = “[" & Format(track, "00") & "] ” & Format(min, “00″) _
& “:” & Format(sec, “00″)
tracktime.Caption = “Track time: ” & trackLength(track)

‘ Check if CD is playing
mciSendString “status cd mode”, s, Len(s), 0
fPlaying = (Mid$(s, 1, 7) = “playing”)
Else
eject.Enabled = False
‘ Disable all the controls, clear the display
If (fCDLoaded = True) Then
play.Enabled = False
pause.Enabled = False
ff.Enabled = False
rew.Enabled = False
ftrack.Enabled = False
btrack.Enabled = False
stopbtn.Enabled = False
fCDLoaded = False
fPlaying = False
totalplay.Caption = “”
tracktime.Caption = “”
timeWindow.Text = “”
End If
End If
End Sub
‘ Set the fast-forward speed
Private Sub ffspeed_Click()
Dim s As String
s = InputBox(”Enter the new speed in seconds”, “Fast Forward Speed”, CStr(fastForwardSpeed))
If IsNumeric(s) Then
fastForwardSpeed = CLng(s)
End If
End Sub

Private Sub Timer1_Timer()
Update
End Sub

‘Module
Option Explicit

Declare Function mciGetErrorString Lib “winmm.dll” Alias “mciGetErrorStringA” (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Declare Function mciSendString Lib “winmm.dll” Alias “mciSendStringA” (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

‘add 1 Label and 1 command button

Private Sub Command1_Click()
Label1.Move (0)
Label1.Caption = Berubah!!!”
End Sub

‘add 1 timer and 2 command buttons
Dim wkday
Dim mnthday
Dim mnth

Private Sub comm2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Randomize (
comm1.Visible = True
comm2.Visible = False
comm1.ForeColor = QBColor(Rnd(8))
End Sub

Private Sub comm1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Randomize (
comm1.Visible = False
comm2.Visible = True
comm2.ForeColor = QBColor(Rnd(8))
End Sub

Private Sub Form_Load()
Me.Height = 4500
Me.Width = 8500
Me.Left = 1800
Me.Top = 2000

wkday = Weekday(Now)
mnth = Month(Now)
If wkday = 1 Then
wkday = “Sunday”
ElseIf wkday = 2 Then
wkday = “Monday”
ElseIf wkday = 3 Then
wkday = “Tuesday”
ElseIf wkday = 4 Then
wkday = “Wednesday”
ElseIf wkday = 5 Then
wkday = “Thursday”
ElseIf wkday = 6 Then
wkday = “Friday”
ElseIf wkday = 7 Then
wkday = “Saturday”
End If
If mnth = 1 Then
mnth = “January”
ElseIf mnth = 2 Then
mnth = “February”
ElseIf mnth = 3 Then
mnth = “March”
ElseIf mnth = 4 Then
mnth = “April”
ElseIf mnth = 5 Then
mnth = “May”
ElseIf mnth = 6 Then
mnth = “June”
ElseIf mnth = 7 Then
mnth = “July”
ElseIf mnth = 8 Then
mnth = “August”
ElseIf mnth = 9 Then
mnth = “September”
ElseIf mnth = 10 Then
mnth = “October”
ElseIf mnth = 11 Then
mnth = “November”
ElseIf mnth = 12 Then
mnth = “December”
End If
End Sub

Private Sub Timer1_Timer()
Me.Caption = Time & “, ” & wkday & “, ” & mnth & ” ” & Day(Now) & “, ” & Year(Now)
timelbl.Caption = Time & “, ” & wkday & “, ” & mnth & ” ” & Day(Now) & “, ” & Year(Now)
End Sub

‘add 2 command buttons and 1 text

Private Sub Command1_Click()
Text1.Text = CapFirst$(Text1.Text)
End Sub

Private Sub Command2_Click()
Text1.Text = LCase$(Text1.Text)
End Sub

‘add 1 module
Declare Function CapFirst$ Lib “CAPFIRST.DLL” Alias “CAPFIRST” (ByVal St$)

‘add 1 ListView, 1 treeview, 1 ImageList, 1 Label and 1 text

Option Explicit
Dim OsVers As OsVersionInfo

Private Sub ResizeControls()
‘—————————————————–
‘Resize controls when the user resizes the form
‘or moves the splitter bar.
‘—————————————————–
On Error GoTo ReSizeError
TreeView1.Move 5 * Screen.TwipsPerPixelX, TreeView1.Top, Picture1.Left - 5 * Screen.TwipsPerPixelX, ScaleHeight - TreeView1.Top - Text1.Height - 5 * Screen.TwipsPerPixelY
ListView1.Move Picture1.Left + Picture1.Width, TreeView1.Top, ScaleWidth - Picture1.Left - Picture1.Width - 5 * Screen.TwipsPerPixelX, TreeView1.Height
Picture1.Top = TreeView1.Top
Picture1.Height = TreeView1.Height

Label1.Left = TreeView1.Left + 60

Text1.Move TreeView1.Left, ScaleHeight - Text1.Height, ScaleWidth - 2 * TreeView1.Left
Exit Sub
ReSizeError:
Exit Sub

End Sub

Private Sub Form_DragDrop(Source As Control, x As Single, y As Single)
If Source = Picture1 Then
Picture1.Left = x
ResizeControls
End If

End Sub

Private Sub Form_Load()
Width = 600 * Screen.TwipsPerPixelX
Picture1.Width = 5 * Screen.TwipsPerPixelX
Picture1.Left = 250 * Screen.TwipsPerPixelX
Dim nodX As Node
Dim ClmHdr As ColumnHeader

‘—————————————————–
‘ add columns to listview control
‘—————————————————–
Set ClmHdr = ListView1.ColumnHeaders.Add()
ClmHdr.Text = “Name”
ClmHdr.Width = ListView1.Width / 3
Set ClmHdr = Me.ListView1.ColumnHeaders.Add()
ClmHdr.Text = “Data”
ClmHdr.Width = 3 * ListView1.Width / 2
‘—————————————————–
‘First we find out what Windows is running. There are a
‘couple of registry keys in Win95 that are not present
‘in Windows NT
‘—————————————————–
OsVers.dwVersionInfoSize = 148&
lTempLong = GetVersionEx(OsVers)
Select Case OsVers.dwPlatform
Case VER_PLATFORM_WIN32_NT
iWinVers = WinNt
Case VER_PLATFORM_WIN32_WINDOWS
iWinVers = Win32
Case Else ‘Shouldn’t happen
MsgBox “This program is intended only for use with 32-bit Windows versions.”
Unload Form1
End Select

‘—————————————————–
‘Start the TreeView with a toplevel key
‘—————————————————–

Set nodX = TreeView1.Nodes.Add(, , “main”, “My Computer”, 3)

‘—————————————————–
‘Put in Public main keys
‘—————————————————–

Set nodX = TreeView1.Nodes.Add(”main”, tvwChild, “HKEY_CLASSES_ROOT”, “HKEY_CLASSES_ROOT”, 1)
nodX.EnsureVisible ‘Forces the tree open to this level
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False ‘Enumerate a single rgeSubKey, to put a + on the key
Set nodX = TreeView1.Nodes.Add(”main”, tvwChild, “HKEY_CURRENT_USER”, “HKEY_CURRENT_USER”, 1)
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False
Set nodX = TreeView1.Nodes.Add(”main”, tvwChild, “HKEY_LOCAL_MACHINE”, “HKEY_LOCAL_MACHINE”, 1)
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False
Set nodX = TreeView1.Nodes.Add(”main”, tvwChild, “HKEY_USERS”, “HKEY_USERS”, 1)
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False

‘—————————————————–
‘Put in version-specific main keys
‘HKEY_PERFORMANCE_DATA does not respond in a normal fashion
‘to key queries.  Note it does not appear in REGEDT32.
‘If iWinVers = WinNT Then
‘treeview1.AddItem “HKEY_PERFORMANCE_DATA”
‘End If
‘—————————————————–
If iWinVers = Win32 Then
Set nodX = TreeView1.Nodes.Add(”main”, tvwChild, “HKEY_CURRENT_CONFIG”, “HKEY_CURRENT_CONFIG”, 1)
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False
Set nodX = TreeView1.Nodes.Add(”main”, tvwChild, “HKEY_DYN_DATA”, “HKEY_DYN_DATA”, 1)
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
RegEnumKeys nodX, False
End If
‘—————————————————–
‘Setup hourglass cursor
‘—————————————————–
iWaitCursor = LoadCursor(0, IDC_WAIT)

End Sub

Private Sub Form_Resize()
ResizeControls
End Sub

Private Sub listview1_DblClick()
‘ if nothing selected get out
If Not (ListView1.SelectedItem Is Nothing) Then
‘———————————————————-
‘Call EditRegValue to load the value into the editor.
‘———————————————————-
EditRegValue TreeView1.Nodes(TreeView1.SelectedItem.Key), CLng(ListView1.ListItems(ListView1.SelectedItem.Index).Tag)
End If

End Sub

Private Sub ListView1_DragDrop(Source As Control, x As Single, y As Single)
If Source = Picture1 Then
Picture1.Left = x + ListView1.Left
ResizeControls
End If

End Sub

Private Sub TreeView1_Collapse(ByVal Node As ComctlLib.Node)
Text1 = truncatepath(Node.FullPath, Me, Text1)

End Sub

Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single)
If Source = Picture1 Then
Picture1.Left = x + TreeView1.Left
ResizeControls
End If
End Sub

Private Sub TreeView1_Expand(ByVal Node As Node)
If Node.Children > 1 Then Exit Sub
If Node.Text = “My Computer” Then Exit Sub
RegEnumKeys Node, True
Node.Sorted = True

End Sub

Private Sub TreeView1_NodeClick(ByVal Node As Node)

‘—————————————————–
‘Empty the value list.
‘—————————————————–
ListView1.ListItems.Clear

‘—————————————————–
‘Remember which line was clicked when we start
‘   moving up and down the list.
‘—————————————————–

rgeSubKey = Node.FullPath
Text1 = truncatepath(Node.FullPath, Me, Text1)
If rgeSubKey = “My Computer” Then Exit Sub
‘—————————————————–
‘Now enumerate all values belonging to this key
‘—————————————————–
ListView1.Sorted = False
RegEnumValues
ListView1.Sorted = True
End Sub

‘Now the module

Option Explicit

Type FILETIME
lLowDateTime    As Long
lHighDateTime   As Long
End Type

Type OsVersionInfo
dwVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatform As Long
szCSDVersion As String * 128
End Type

Declare Function RegOpenKeyEx& Lib “advapi32.dll” Alias “RegOpenKeyExA” (ByVal hKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&amp
Declare Function RegCloseKey& Lib “advapi32.dll” (ByVal hKey&amp
Declare Function RegQueryValueEx& Lib “advapi32.dll” Alias “RegQueryValueExA” (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&amp
Declare Function RegSetValueEx& Lib “advapi32.dll” Alias “RegSetValueExA” (ByVal hKey&, ByVal lpszValueName$, ByVal dwRes&, ByVal dwType&, lpDataBuff As Any, ByVal nSize&amp
Declare Function RegConnectRegistry& Lib “advapi32.dll” (ByVal lpMachineName$, ByVal hKey&, phkResult&amp
Declare Function RegCreateKeyEx& Lib “advapi32.dll” Alias “RegCreateKeyExA” (ByVal hKey&, ByVal lpSubKey$, ByVal Reserved&, ByVal lpClass$, ByVal dwOptions&, ByVal samDesired&, lpSecurityAttributes&, phkResult&, lpdwDisposition&amp
Declare Function RegFlushKey& Lib “advapi32.dll” (ByVal hKey&amp
Declare Function RegEnumKeyEx& Lib “advapi32.dll” Alias “RegEnumKeyExA” (ByVal hKey&, ByVal dwIndex&, ByVal lpname$, lpcbName&, ByVal lpReserved&, ByVal lpClass$, lpcbClass&, lpftLastWriteTime As FILETIME)

Declare Function RegEnumValue& Lib “advapi32.dll” Alias _
“RegEnumValueA” (ByVal hKey&, ByVal dwIndex&, ByVal lpname$, _
lpcbName&, ByVal lpReserved&, lpdwType&, lpValue As Any, lpcbValue&amp

Declare Function RegQueryInfoKey& Lib “advapi32.dll” Alias “RegQueryInfoKeyA” (ByVal hKey&, ByVal lpClass$, lpcbClass&, ByVal lpReserved&, lpcSubKeys&, lpcbMaxSubKeyLen&, lpcbMaxClassLen&, lpcValues&, lpcbMaxValueNameLen&, lpcbMaxValueLen&, lpcbSecurityDescriptor&, lpftLastWriteTime As FILETIME)

Declare Function GetVersionEx& Lib “kernel32.dll” Alias “GetVersionExA” (lpStruct As OsVersionInfo)

Declare Function LoadCursor& Lib “User32″ Alias “LoadCursorA” (ByVal hInstance&, ByVal lpCursor&amp
Declare Function SetCursor& Lib “User32″ (ByVal hCursor&amp
Public Const IDC_WAIT = 32514&

Public iWaitCursor&

Public lNewKey& ‘used to generate unique Node keys

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&

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 LB_SETHORIZONTALEXTENT = &H400 + 21

Const REG_NONE = 0&                        ‘ No value type
Public Const REG_SZ = 1&                   ‘ Unicode nul terminated string
Const REG_EXPAND_SZ = 2&                   ‘ Unicode nul terminated string
‘ (with environment variable references)
Const REG_BINARY = 3&                      ‘ Free form binary
Public Const REG_DWORD = 4&                ‘ 32-bit number
Const REG_DWORD_LITTLE_ENDIAN = 4&         ‘ 32-bit number (same as REG_DWORD)
Const REG_DWORD_BIG_ENDIAN = 5&            ‘ 32-bit number
Const REG_LINK = 6&                        ‘ Symbolic Link (unicode)
Const REG_MULTI_SZ = 7&                    ‘ Multiple Unicode strings
Const REG_RESOURCE_LIST = 8&               ‘ Resource list in the resource map
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&    ‘ Resource list in the hardware description
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

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 READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ

Public iWinVers%
Public Const WinNt = 1
Public Const Win32 = 2

Public Const VER_PLATFORM_WIN32_WINDOWS = 1
Public Const VER_PLATFORM_WIN32_NT = 2

Public lTempLong&
Public fTempDbl#
Public sTempString$
Public nodetemp As Node

Public rgeEntry$
Public rgeDataType&
Public rgeValue$
Public rgeMainKey&
Public rgeSubKey$

Public Sub rgeExtractKeys()
‘——————————————————————
‘Enter with rgeSubKey containing a full path in the
‘My Computer\HKEY_…\..\ format or HKEY_…\…\ format
‘————————————————————–
If Left$(rgeSubKey, 12) = “My Computer\” Then
rgeSubKey = Right$(rgeSubKey, Len(rgeSubKey) - 12)
End If

‘—————————————————————-
‘If there is no main key we have to assume it may already have
‘been extracted.
‘—————————————————————
If Left$(rgeSubKey, 5) <> “HKEY_” Then
Exit Sub
ElseIf InStr(rgeSubKey, “\”) = 0 Then
rgeMainKey = GetMainKey(rgeSubKey)
rgeSubKey = “”
Else
rgeMainKey = GetMainKey(Left$(rgeSubKey, InStr(rgeSubKey, “\”) - 1))
rgeSubKey = Right$(rgeSubKey, Len(rgeSubKey) - InStr(rgeSubKey, “\”))
End If
‘ —————————————————–
‘ Check rgeMainKey& for validity
‘ —————————————————–
If rgeMainKey < &H80000000 Or rgeMainKey > &H80000006 Then
rgeClear
End If

End Sub
Public Sub rgeClear()
rgeMainKey = 0
rgeSubKey = “”
rgeValue = “”
rgeDataType = 0
rgeEntry = “”
End Sub

Sub EditRegValue(ByVal nodX As Node, lRegIndex&amp
‘ ——————————————————–
‘ Specific to the RegDemo application.
‘ ——————————————————–
rgeSubKey = nodX.FullPath
rgeSubKey = Right$(rgeSubKey, Len(rgeSubKey) - 12)
If InStr(rgeSubKey, “\”) = 0 Then
rgeMainKey = GetMainKey(rgeSubKey)
rgeSubKey = “”
Else
‘————————————————-
‘This must be a SubKey.
‘————————————————-
rgeMainKey = GetMainKey(Left$(rgeSubKey, InStr(rgeSubKey, “\”) - 1))
rgeSubKey = Right$(rgeSubKey, Len(rgeSubKey) - InStr(rgeSubKey, “\”))
End If

Dim lRtn&       ‘ Returned by registry functions, should be 0&
Dim hKey&       ‘ Return handle to opened key
Dim lLenValueName&
Dim lLenValue&
Dim lKeyIndx&

‘ ——————————————————–
‘ values for QueryInfoKey:
‘ ——————————————————–
Dim sClassName$
Dim lClassLen&
Dim lSubKeys&
Dim lMaxSubKey&
Dim lMaxClass&
Dim lValues&
Dim lMaxValueName&
Dim lMaxValueData&
Dim lSecurityDesc&
Dim strucLastWriteTime As FILETIME

‘ —————————————————–
‘ Open key
‘ —————————————————–
lRtn = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, hKey)
If lRtn <> ERROR_SUCCESS Then
MsgBox RtnRegError(lRtn)

‘ ————————————————–
‘ No key open, so leave
‘ ————————————————–
Exit Sub
End If

‘ —————————————————–
‘ RegQueryInfoKey is used to get the size of the largest
‘   value name and data string.
‘ Other returned values are ignored.
‘ —————————————————–
sClassName = Space$(255) ‘initialize these because occasional errors otherwise
lClassLen = CLng(Len(sClassName))
lRtn = RegQueryInfoKey(hKey, sClassName, lClassLen, 0&, lSubKeys, lMaxSubKey, lMaxClass, lValues, lMaxValueName, lMaxValueData, lSecurityDesc, strucLastWriteTime)

‘——————————————————————-
‘If the enumeration fails due to a buffer over-run, we will loop back
‘to this point with larger buffers.
‘——————————————————————-
RetryValueHere:

‘ ————————————————–
‘ Set variables
‘ ————————————————–
rgeEntry = Space$(lMaxValueName + 1)
lLenValueName = CLng(Len(rgeEntry)) ‘+ 1
rgeValue = Space$(lMaxValueData + 1)
lLenValue = CLng(Len(rgeValue))       ‘+ 1

‘ ————————————————–
‘ Call the enumeration function to get the indexed value
‘ ————————————————–
lRtn = RegEnumValue(hKey, lRegIndex, rgeEntry, lLenValueName, 0&, rgeDataType, ByVal rgeValue, lLenValue)

‘ ————————————————–
‘ Check for success
‘ ————————————————–
If lRtn = ERROR_SUCCESS Then
If rgeDataType <> REG_SZ And rgeDataType <> REG_DWORD Then

‘————————————————————–
‘Tell us what value types may be edited, along with
‘    the type of value found.
‘————————————————————–
sTempString = “This Demo only supports editing of values with types of REG_SZ and REG_DWORD.  This value is of type “
Select Case rgeDataType
Case 2
sTempString = sTempString & “REG_EXPAND_SZ.”
Case 3
sTempString = sTempString & “REG_BINARY.”
Case 5
sTempString = sTempString & “REG_DWORD_BIG_ENDIAN.”
Case 6
sTempString = sTempString & “REG_LINK.”
Case 7
sTempString = sTempString & “REG_MULTI_SZ.”
Case 8
sTempString = sTempString & “REG_RESOURCE_LIST.”
Case 9
sTempString = sTempString & “REG_FULL_RESOURCE_DESCRIPTOR.”
Case 10
sTempString = sTempString & “REG_RESOURCE_REQUIREMENTS_LIST.”
End Select
MsgBox sTempString

Else
rgeEntry = Mid$(rgeEntry, 1, lLenValueName)
If lLenValueName = 0 Then
rgeEntry = “(Default)”
End If
rgeValue = Mid$(rgeValue, 1, lLenValue)
‘ ——————————————–
‘ Convert DWORD 4 character value to 32-bit
‘   number.
‘ First character is low byte, and so on.
‘ ——————————————–
Form2.Caption = “Edit String Value”
If rgeDataType = REG_DWORD Then
fTempDbl = Asc(Mid$(rgeValue, 1, 1)) + &H100& * Asc(Mid$(rgeValue, 2, 1)) + &H10000 * Asc(Mid$(rgeValue, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(rgeValue, 4, 1)))
If fTempDbl > &H7FFFFFFF Then
rgeValue = Hex$(fTempDbl - 4294967296#)
Else
rgeValue = Hex$(fTempDbl)
End If
‘ —————————————–
‘ Turn on Hex/Decimal options
‘ —————————————–
Form2.Frame1.Visible = True
Form2.Caption = “Edit DWORD Value”
End If

‘ ——————————————–
‘ Place the values in the form2 text boxes
‘ ——————————————–
Form2.Text1 = rgeEntry
Form2.Text2 = rgeValue

‘ ——————————————–
‘ Pass the key variables to form2 via hidden
‘   text boxes
‘ ——————————————–
Form2.Show 1
End If

ElseIf lRtn = ERROR_MORE_DATA Then
‘ ———————————————–
‘ This error means that, despite querying the key
‘   we have not set one of the buffers large
‘   enough. If the buffer is already 20000 we are
‘   not going to be able to edit it.
‘ ———————————————–
If lMaxValueData >= 20000 Then
MsgBox (”Value is too large for this editor!”)
Else

‘ ——————————————–
‘ Increase the buffer sizes and try again
‘ ——————————————–
lMaxValueData = lMaxValueData + 5
lMaxValueName = lMaxValueName + 5
GoTo RetryValueHere
End If
Else

‘ ————————————————–
‘ Key still open, so display the error and fall
‘   thru to the close function below
‘ ————————————————–
MsgBox RtnRegError(lRtn)
End If

‘ —————————————————–
‘ Always close opened keys!
‘ —————————————————–
lRtn = RegCloseKey(hKey)

End Sub

Function truncatepath$(TPath$, TForm As Form, TControl As Control)
Dim FirstSlash%
On Error GoTo TPathError
TPath = Right$(TPath, Len(TPath) - InStr(TPath, “H”) + 1)
FirstSlash = InStr(3, TPath, “\”)
Do Until TForm.TextWidth(TPath) <= TControl.Width
lTempLong = InStr(FirstSlash + 5, TPath, “\”)
TPath = Left$(TPath, FirstSlash) & “…” & Mid$(TPath, lTempLong, Len(TPath) - lTempLong + 1)
Loop
TooLong:
On Error GoTo StillError
If TForm.TextWidth(TPath) > TControl.Width Then
Do Until TForm.TextWidth(TPath) <= TControl.Width
TPath = Left$(TPath, Len(TPath) - 1)
Loop
TPath = Left$(TPath, Len(TPath) - 3) & “…”
End If
FinishAnyWay:
truncatepath = TPath
Exit Function
TPathError:
Resume TooLong
StillError:
Resume FinishAnyWay
End Function

Function GetMainKey&(keyname$)

‘ —————————————————–
‘ Used to convert main key strings to their values
‘ —————————————————–

Select Case keyname
Case “HKEY_CLASSES_ROOT”
GetMainKey = HKEY_CLASSES_ROOT
Case “HKEY_CURRENT_USER”
GetMainKey = HKEY_CURRENT_USER
Case “HKEY_LOCAL_MACHINE”
GetMainKey = HKEY_LOCAL_MACHINE
Case “HKEY_USERS”
GetMainKey = HKEY_USERS
Case “HKEY_PERFORMANCE_DATA”
GetMainKey = HKEY_PERFORMANCE_DATA
Case “HKEY_CURRENT_CONFIG”
GetMainKey = HKEY_CURRENT_CONFIG
Case “HKEY_DYN_DATA”
GetMainKey = HKEY_DYN_DATA
End Select

End Function

Function RegEnumKeys&(ByVal Node As Node, bFullEnumeration As Boolean)
lTempLong = SetCursor(iWaitCursor)
Dim sRoot$, sRoot2$
rgeSubKey = Node.FullPath
If rgeSubKey = “My Computer” Then
Exit Function
End If
‘———————————————
‘If we’ve put in a fake node to set the + image,
‘remove that node to avoid duplication
‘———————————————
While Node.Children > 0
Form1.TreeView1.Nodes.Remove Node.Child.Key
Wend
Form1.TreeView1.Enabled = False
rgeExtractKeys
sRoot = Node.Key
‘ ——————————————————–
‘ This function will load all subkeys into the TreeView
‘ ——————————————————–
Dim lRtn&       ‘ Returned by registry functions, should be 0&
Dim hKey&       ‘ Return handle to opened key
Dim strucLastWriteTime    As FILETIME
Dim sSubKeyName$
Dim sClassString$
Dim lLenSubKey&
Dim lLenClass&
Dim lKeyIndx&
Dim lRet&
Dim hKey2&
Dim sSubKey2$
Dim nodX As Node
Dim sNewKey$

‘———————————————
‘values for QueryInfoKey:
‘———————————————
Dim sClassName$
Dim lClassLen&
Dim lSubKeys&
Dim lMaxSubKey&
Dim sMaxSubKey$
Dim lMaxClass&
Dim sMaxClass$
Dim lValues&
Dim lMaxValueName&
Dim lMaxValueData&
Dim lSecurityDesc&

‘ —————————————————–
‘ Open key
‘ —————————————————–
lRtn = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, hKey)
If lRtn <> ERROR_SUCCESS Then
If lRtn = ERROR_ACCESS_DENIED Then
‘———————————————
‘Grey the key
‘otherwise report error condition
‘———————————————
Node.Image = 6
‘Node.Enabled = False ‘Doesn’t work?
Else
MsgBox RtnRegError(lRtn)
End If
RegEnumKeys = lRtn
Form1.TreeView1.Enabled = True
Exit Function

‘ ————————————————–
‘ No key open, so leave
‘ ————————————————–
End If

‘ —————————————————–
‘ A call to RegQueryInfoKey will tell us the maximum
‘   keyname length
‘ —————————————————–
sClassName = Space$(255)
lClassLen = CLng(Len(sClassName))
lRet = RegQueryInfoKey(hKey, sClassName, lClassLen, 0&, lSubKeys, lMaxSubKey, lMaxClass, lValues, lMaxValueName, lMaxValueData, lSecurityDesc, strucLastWriteTime)
sMaxSubKey = Space$(lMaxSubKey + 1)
sMaxClass = Space$(lMaxClass + 1)

‘ —————————————————–
‘ Enumerate the keys
‘ —————————————————–
lKeyIndx = 0&
Do While lRtn = ERROR_SUCCESS

‘ —————————————————–
‘ If the enumeration fails due to a buffer over-run,
‘   we will loop back to this point with larger buffers.
‘ —————————————————–
ReTryKeyEnumeration:

‘ ————————————————–
‘ Set variables
‘ ————————————————–
sSubKeyName = sMaxSubKey
lLenSubKey = lMaxSubKey
sClassString = sMaxClass
lLenClass = lMaxClass

‘ ————————————————–
‘ Call the enumeration function
‘ ————————————————–
lRtn = RegEnumKeyEx(hKey, lKeyIndx, sSubKeyName, lLenSubKey, 0&, sClassString, lLenClass, strucLastWriteTime)
If InStr(sSubKeyName, Chr$(0)) > 1 Then
sSubKeyName = Left$(sSubKeyName, InStr(sSubKeyName, Chr$(0)) - 1)
End If

‘ ————————————————–
‘ Check for success
‘ ————————————————–
If lRtn = ERROR_SUCCESS Then
lNewKey = lNewKey + 1
sNewKey = “A” & Format$(lNewKey, “000000″)
Set nodX = Form1.TreeView1.Nodes.Add(sRoot, tvwChild, sNewKey, sSubKeyName, 1)
If bFullEnumeration = True Then
sSubKey2 = sSubKeyName
If rgeSubKey <> “” Then
sSubKey2 = Trim(rgeSubKey) & “\” & sSubKeyName
End If

‘ ———————————————–
‘ Use RegQueryInfoKey to find out if this key has
‘   subkeys
‘ ———————————————–
lRet = RegOpenKeyEx(rgeMainKey, sSubKey2, 0&, KEY_READ, hKey2)
‘——————————————————
‘We are fully enumerating a key, so set images and
‘Recurse a single SubKey to set + indicator if there are
’subkeys below this one
‘——————————————————
If lRet = ERROR_ACCESS_DENIED Then
nodX.ExpandedImage = 6
nodX.SelectedImage = 6
ElseIf lRet = ERROR_SUCCESS Then
nodX.ExpandedImage = 2
nodX.SelectedImage = 2
lRet = RegQueryInfoKey(hKey2, vbNullString, 0&, 0&, lSubKeys, 0&, 0&, 0&, 0&, 0&, 0&, strucLastWriteTime)
‘ ————————————————–
‘ Check for success.  If lSubKeys is greater than zero
‘ there are subkeys for this key, and we will set a fake
‘ node under this one to make a + symbol.
‘ ————————————————–
If lRet = ERROR_SUCCESS And lSubKeys > 0 Then
sRoot2 = nodX.Key
lNewKey = lNewKey + 1
sNewKey = “A” & Format$(lNewKey, “000000″)
Set nodX = Form1.TreeView1.Nodes.Add(sRoot2, tvwChild, sNewKey, “PlaceHolder”, 1)
End If
lRet = RegCloseKey(hKey2)
End If
Else
Exit Do
End If
lKeyIndx = lKeyIndx + 1
ElseIf lRtn = ERROR_MORE_DATA Then
‘ ———————————————–
‘ This error means that, despite querying the key
‘   we have not set one of the buffers large
‘   enough.Increment the buffer sizes and try
‘   again
‘ ———————————————–
lMaxSubKey = lMaxSubKey + 5
lMaxClass = lMaxClass + 5
sMaxSubKey = Space$(lMaxSubKey + 1)
sMaxClass = Space$(lMaxClass + 1)
GoTo ReTryKeyEnumeration
ElseIf lRtn = ERROR_NO_MORE_ITEMS Then
‘ ———————————————–
‘ Not an error, just end of list — exit the
‘   loop
‘ ———————————————–
lRtn = ERROR_SUCCESS
Exit Do
ElseIf lRtn <> ERROR_SUCCESS Then
‘ ————————————————–
‘ Key still open, so display the error and fall
‘   thru to the close function below
‘ ————————————————–
MsgBox RtnRegError(lRtn)
Exit Do
End If
Loop

‘ —————————————————–
‘ Set the return to the last error
‘ —————————————————–
RegEnumKeys = lRtn

‘ —————————————————–
‘ Always close opened keys!
‘ —————————————————–
lRtn = RegCloseKey(hKey)
Form1.TreeView1.Enabled = True
End Function
Public Sub RegEnumValues()
‘ ——————————————————–
‘Enter with rgeSubKey containing a full key path, in
‘My Computer\HKEY_..\..\ fashion
‘ ——————————————————–
‘When you don’t need to enumerate all values, but just want to
‘retrive a single value, use the provided function RegGetValue
‘———————————————————
Dim lRtn&        ‘ Returned by registry functions, should be 0&
Dim hKey&       ‘ Return handle to opened key
Dim lLenValueName&
Dim lLenValue&
Dim lKeyIndx&
Dim sBinaryString$
Dim Item As ListItem
Dim iTempInt%
‘—————————
‘values for QueryInfoKey:
‘—————————
Dim sClassName$
Dim lClassLen&
Dim lSubKeys&
Dim lMaxSubKey&
Dim lMaxClass&
Dim lValues&
Dim lMaxValueName&
Dim lMaxValueData&
Dim lSecurityDesc&
Dim strucLastWriteTime As FILETIME
Dim pbytValueName() As Byte
Dim pbytValue() As Byte
Dim DataType&
Dim ValueName$
Dim ValueVal$

Dim iListWidth%  ‘Used to set listbox scrollbar

lTempLong = SetCursor(iWaitCursor)

rgeExtractKeys

‘ —————————————————–
‘ Open key
‘ —————————————————–
lRtn = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, hKey)
If lRtn <> ERROR_SUCCESS Then
If lRtn <> ERROR_ACCESS_DENIED Then
‘———————————————
‘If access is denied don’t do anything
‘———————————————
MsgBox RtnRegError(lRtn)
End If
rgeClear

‘ ————————————————–
‘ No key open, so leave
‘ ————————————————–
Exit Sub
End If

‘ —————————————————–
‘ Use RegQueryInfoKey to get the maximum value data info.
‘ —————————————————–
sClassName = Space$(255)
lClassLen = CLng(Len(sClassName))
lRtn = RegQueryInfoKey(hKey, sClassName, lClassLen, 0&, lSubKeys, lMaxSubKey, lMaxClass, lValues, lMaxValueName, lMaxValueData, lSecurityDesc, strucLastWriteTime)

‘ —————————————————–
‘ Enumerate the keys
‘ —————————————————–
lKeyIndx = 0&
Do While lRtn = ERROR_SUCCESS And lKeyIndx < lValues
sBinaryString = “”

‘——————————————————————-
‘If the enumeration fails due to a buffer over-run, we will loop back
‘to this point with larger buffers.
‘——————————————————————-
ReTryValueEnumeration:

‘ ————————————————–
‘ Set variables
‘ ————————————————–
ValueName = Space$(lMaxValueName + 1)
lLenValueName = CLng(Len(ValueName)) ‘+ 1
ValueVal = Space$(lMaxValueData + 1)
lLenValue = CLng(Len(ValueVal))       ‘+ 1

‘ ————————————————–
‘ Call the enumeration function
‘ ————————————————–
‘lRtn = RegEnumValue(hKey, lKeyIndx, pbytValueName(0), _
‘lLenValueName, vbNull, rgeDataType, pbytValue(0), _
‘lLenValue)
lRtn = RegEnumValue(hKey, lKeyIndx, ValueName, _
lLenValueName, 0&, DataType, ByVal ValueVal, _
lLenValue)

‘ ————————————————–
‘ Check for success
‘ ————————————————–
If lRtn = ERROR_SUCCESS Then

rgeEntry = ValueName
rgeDataType = DataType
rgeValue = ValueVal
‘rgeValue = pbytValue()
‘———————————————–
‘Add an item to the list box
‘———————————————–
Set Item = Form1.ListView1.ListItems.Add()

‘ ———————————————–
‘ Start building the entry to put in the list box:
‘ ———————————————–
rgeEntry = Mid$(rgeEntry, 1, lLenValueName)

‘ ———————————————–
‘ Default values don’t have a name.
‘ ———————————————–
If lLenValueName = 0 Then
rgeEntry = “(Default)”
End If

rgeValue = Mid$(rgeValue, 1, lLenValue)
Select Case rgeDataType
Case REG_MULTI_SZ
‘ ————————————–
‘ REG_MULTI_SZ strings are a series of
‘   zero terminated strings. If we don’t
‘   strip out the zeros, only the first
‘   one will display.
‘ We will replace them with spaces.
‘ ————————————–
Item.SmallIcon = 4
Do While InStr(rgeValue, Chr$(0))
rgeValue = Left$(rgeValue, InStr(rgeValue, Chr$(0)) - 1) & ” ” & Right$(rgeValue, Len(rgeValue) - InStr(rgeValue, Chr$(0)))
Loop
Case REG_SZ
‘ ————————————–
‘ REG_SZ values are zero-terminated
‘   strings, and are the most common
‘   values.
‘ ————————————–
Item.SmallIcon = 4

‘—————————————
‘Put quotes around the string
‘—————————————
rgeValue = “”"” & Left$(rgeValue, lLenValue - 1) & “”"”

Case REG_EXPAND_SZ
‘—————————————
‘Environmental variables that are binary
‘but evaluate as strings.  Not edited by
‘this program.
‘—————————————
Item.SmallIcon = 5
Case REG_FULL_RESOURCE_DESCRIPTOR
‘ ————————————–
‘ Resource Descriptors require a special
‘   editor to properly be displayed or
‘   edited.
‘ ————————————–
Item.SmallIcon = 5
rgeValue = “REG_FULL_RESOURCE_DESCRIPTOR”

Case REG_DWORD
‘ ————————————–
‘ REG_DWORD values are 32-bit unsigned
‘   integers
‘ Tortuous manipulation to make values
‘   above 7FFFFFFF appear as positive
‘   values.
‘ VB Longs would display them as
‘   negative numbers.
‘ ————————————–
Item.SmallIcon = 5
fTempDbl = Asc(Mid$(rgeValue, 1, 1)) + &H100& * Asc(Mid$(rgeValue, 2, 1)) + &H10000 * Asc(Mid$(rgeValue, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(rgeValue, 4, 1)))
If fTempDbl > &H7FFFFFFF Then
rgeValue = “&H” & Hex$(fTempDbl - 4294967296#)
Else
rgeValue = “&H” & Hex$(fTempDbl)
End If
rgeValue = rgeValue & ” (” & Format$(fTempDbl) & “)”

Case REG_BINARY

‘ ————————————–
‘ Binary values may be of any length,
‘   and may represent text or other data.
‘ They require a special editor to
‘   modify them.
‘ ————————————–
Item.SmallIcon = 5
For iTempInt = 1 To Len(rgeValue)
sBinaryString = sBinaryString & Format$(Hex(Asc(Mid$(rgeValue, iTempInt, 1))), “00″) & ” “
Next iTempInt
rgeValue = sBinaryString
End Select

If Len(rgeValue) = 0 Then
rgeValue = “(value not set)”
End If

‘ ———————————————–
‘ Enter the value into the list box
‘ ———————————————–
Item.Text = rgeEntry
Item.SubItems(1) = rgeValue
Item.Tag = CStr(lKeyIndx)
‘ ———————————————–
‘ Increment the key and do it again.
‘ ———————————————–
lKeyIndx = lKeyIndx + 1

ElseIf lRtn = ERROR_MORE_DATA Then
‘ ———————————————–
‘ This error means that, despite querying the key,
‘   we have not set one of the buffers large
‘   enough.  Increment the buffer sizes and try
‘   again
‘ ———————————————–
lMaxValueData = lMaxValueData + 5
lMaxValueName = lMaxValueName + 5
GoTo ReTryValueEnumeration

ElseIf lRtn = ERROR_NO_MORE_ITEMS Then
‘ ———————————————–
‘ Not an error, just end of list — exit the
‘   loop
‘ ———————————————–
lRtn = ERROR_SUCCESS
Exit Do

Else
‘ ————————————————–
‘ Key still open, so display the error and fall
‘   thru to the close function below
‘ ————————————————–
MsgBox RtnRegError(lRtn)
Exit Do
End If
Loop

‘ —————————————————–
‘ Always close opened keys!
‘ —————————————————–
lRtn = RegCloseKey(hKey)

End Sub

Function RegGetValue$()
‘ This function is not used in this demo, but is a sample for
‘ retrieving a single value
‘ rgeMainKey must be one of the Publicly declared HKEY constants.
Dim sKeyType&       ‘returns the key type.  This function expects REG_SZ or REG_DWORD
Dim ret&            ‘returned by registry functions, should be 0&
Dim lpHKey&         ‘return handle to opened key
Dim lpcbData&       ‘length of data in returned string
Dim ReturnedString$ ‘returned string rgeValue
Dim fTempDbl!
If rgeMainKey >= &H80000000 And rgeMainKey <= &H80000006 Then
‘ Open key
ret = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, lpHKey)
If ret <> ERROR_SUCCESS Then
RegGetValue = “”
Exit Function     ‘No key open, so leave
End If

‘ Set up buffer for data to be returned in.
‘ Adjust next rgeValue for larger buffers.
lpcbData = 255
ReturnedString = Space$(lpcbData)

‘ Read key
ret& = RegQueryValueEx(lpHKey, rgeValue, ByVal 0&, sKeyType, ReturnedString, lpcbData)
If ret <> ERROR_SUCCESS Then
RegGetValue = “”   ‘Key still open, so finish up
Else
If sKeyType = REG_DWORD Then
fTempDbl = Asc(Mid$(ReturnedString, 1, 1)) + &H100& * Asc(Mid$(ReturnedString, 2, 1)) + &H10000 * Asc(Mid$(ReturnedString, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(ReturnedString, 4, 1)))
ReturnedString = Format$(fTempDbl, “000″)
End If
RegGetValue = Left$(ReturnedString, lpcbData - 1)
End If
‘ Always close opened keys.
ret = RegCloseKey(lpHKey)
End If
End Function

Sub RegSetValue()
‘ ——————————————————–
‘ DWORD Values must be in Hex form for this function to
‘   work.
‘ ——————————————————–
Dim lRtn&            ‘returned by registry functions, should be 0&
Dim hKey&         ‘return handle to opened key
Dim iFirstChar%
Dim iSecondChar%
Dim iThirdChar%
Dim iFourthChar%
Dim lpDisp&

If rgeDataType <> REG_SZ And rgeDataType <> REG_DWORD Then
MsgBox “This demo only supports writing keys of the types REG_SZ and REG_DWORD.  This key uses a different type.”
Exit Sub
End If

‘ —————————————————–
‘ Check rgeMainKey for validity
‘ —————————————————–
If rgeMainKey >= &H80000000 And rgeMainKey <= &H80000006 Then

‘ —————————————————–
‘ Open key
‘ —————————————————–
lRtn = RegCreateKeyEx(rgeMainKey, rgeSubKey, 0&, “”, 0&, KEY_WRITE, 0&, hKey, lpDisp)
If lRtn <> ERROR_SUCCESS Then
MsgBox RtnRegError(lRtn)
rgeClear
Exit Sub       ‘No key open, so leave
End If

‘ —————————————————–
‘ Write new rgeValue to key
‘ —————————————————–
If rgeDataType = REG_DWORD Then
rgeValue = Left(Trim(rgeValue),
If Left$(rgeValue, 2) <> “&H” Then
rgeValue = “&H” & Left(Trim(rgeValue),
End If
If Len(rgeValue) <= 6 Then
rgeValue = rgeValue & “&”
End If

‘ —————————————————–
‘Convert number string to 32-bit DWORD and save:
‘ —————————————————–
lRtn = RegSetValueEx(hKey, rgeEntry, 0&, rgeDataType, CLng(Val(rgeValue)), 4&amp
Else

‘ —————————————————–
‘Save type REG_SZ (strings)
‘ —————————————————–
lRtn = RegSetValueEx(hKey, rgeEntry, 0&, rgeDataType, ByVal rgeValue, CLng(Len(rgeValue)))
End If
If lRtn <> ERROR_SUCCESS Then
MsgBox RtnRegError(lRtn) ‘Key still open, so finish up
End If
‘ —————————————————–
‘ Always close opened keys!
‘ —————————————————–
lRtn = RegCloseKey(hKey)
End If
End Sub

Private Function RtnRegError$(errorcode&amp
Select Case errorcode
Case 1009, 1015
‘ —————————————————–
‘We’re in trouble now
‘ —————————————————–
RtnRegError = “The Registry Database is corrupt!”
Case 2, 1010
RtnRegError = “Bad Key Name!”
Case 1011
RtnRegError = “Can’t Open Key”
Case 4, 1012
RtnRegError = “Can’t Read Key”
Case 5
RtnRegError = “Access to this key is denied.”
Case 1013
RtnRegError = “Can’t Write Key”
Case 8, 14
RtnRegError = “Out of memory”
Case 87
RtnRegError = “Invalid Parameter”
Case 234
RtnRegError = “Error - There is more data than the buffer can handle!”
Case Else
RtnRegError = “Undefined Key Error Code” & Str$(errorcode) & “!”
End Select
End Function

Function WordLo(lLongIn&amp As Integer
If (lLongIn And &HFFFF&amp > &H7FFF Then
WordLo = (lLongIn And &HFFFF&amp