Hanoi Tower


Option Explicit
Dim intDiskToPole() As Integer
Dim intToPtr As Integer
Dim intDiskFromPole() As Integer
Dim intFromPtr As Integer
Dim intDiskUsingPole() As Integer
Dim intUsingPtr As Integer
Dim Line1() As Line
Dim NODisks As Integer
Dim txtRules As String
Dim StopHere As Boolean

‘Main Recursive Logic for solving Tower Of Hanoi
Private Sub SolveHanoi(strFrom As String, strTO As String, strUsing As String, NOD As Integer)
If StopHere Then Exit Sub
If NOD > 0 Then
SolveHanoi strFrom, strUsing, strTO, NOD – 1 ‘Step 1
If StopHere Then Exit Sub
txtOutput.Text = txtOutput.Text & vbCrLf & “Disk ” & NOD & ” Moved From ” & strFrom & ” To ” & strTO
If StopHere Then Exit Sub
Select Case strFrom ‘Step 2
Case “Left”:
ShowTransition strFrom, strTO, strUsing, intDiskFromPole(intFromPtr)
Case “Right”:
ShowTransition strFrom, strTO, strUsing, intDiskToPole(intToPtr)
Case “Middle”:
ShowTransition strFrom, strTO, strUsing, intDiskUsingPole(intUsingPtr)
End Select
If StopHere Then Exit Sub
If optStandard.Value Then
AddDelay
ElseIf optDynamic.Value Then
Pause 1 / NODisks
End If
If StopHere Then Exit Sub
SolveHanoi strUsing, strTO, strFrom, NOD – 1 ‘Step 3
End If
End Sub

‘Delay Loop
Private Sub AddDelay()
Dim i As Integer
Dim j As Integer

For i = 0 To 800
For j = 0 To 800
DoEvents
Next j
Next i
End Sub

‘Here Transitions are shown
Private Sub ShowTransition(strFrom As String, strTO As String, strUsing As String, NOD As Integer)
Dim i As Integer
Dim DiskNO As Integer

DiskNO = NOD
For i = 1 To NODisks
Line1(i).Visible = False
Next
AdjustNOD strFrom, -1, DiskNO
AdjustNOD strTO, 1, DiskNO
ShowDisks
End Sub

‘Refresh all componnets for net session of Hanoi solving
Private Sub RemoveAllObjects()
On Error GoTo EndHere
Dim i As Integer
For i = 1 To NODisks
Controls.Remove (“Lin” & (i + 1))
Next i
EndHere:
End Sub

‘Adjust individual Stacks correspoding to each pole
Private Sub AdjustNOD(strPole As String, AddRemove As Integer, DiskValue As Integer)
If AddRemove = -1 Then
Select Case strPole
Case “Left”:
intDiskFromPole(intFromPtr) = 0
intFromPtr = intFromPtr – 1
Case “Right”:
intDiskToPole(intToPtr) = 0
intToPtr = intToPtr – 1
Case “Middle”:
intDiskUsingPole(intUsingPtr) = 0
intUsingPtr = intUsingPtr – 1
End Select
ElseIf AddRemove = 1 Then
Select Case strPole
Case “Left”:
intFromPtr = intFromPtr + 1
intDiskFromPole(intFromPtr) = DiskValue
Case “Right”:
intToPtr = intToPtr + 1
intDiskToPole(intToPtr) = DiskValue
Case “Middle”:
intUsingPtr = intUsingPtr + 1
intDiskUsingPole(intUsingPtr) = DiskValue
End Select
End If
End Sub

‘Print Current Stacks
Private Sub ShowDisks()
Dim i As Integer

‘ In Case “Left”:
For i = 1 To intFromPtr
Line1(intDiskFromPole(i)).X1 = 240 + 150 * intDiskFromPole(i)
Line1(intDiskFromPole(i)).Y1 = 5160 – 200 * i
Line1(intDiskFromPole(i)).X2 = 2880 + 240 – 150 * intDiskFromPole(i)
Line1(intDiskFromPole(i)).Y2 = 5160 – 200 * i
Line1(intDiskFromPole(i)).Visible = True
Next
‘ In Case “Right”:
For i = 1 To intToPtr
Line1(intDiskToPole(i)).X1 = 6220 + 150 * intDiskToPole(i)
Line1(intDiskToPole(i)).Y1 = 5160 – 200 * i
Line1(intDiskToPole(i)).X2 = 2880 + 6220 – 150 * intDiskToPole(i)
Line1(intDiskToPole(i)).Y2 = 5160 – 200 * i
Line1(intDiskToPole(i)).Visible = True
Next
‘ In Case “Middle”:
For i = 1 To intUsingPtr
Line1(intDiskUsingPole(i)).X1 = 3200 + 150 * (intDiskUsingPole(i))
Line1(intDiskUsingPole(i)).Y1 = 5160 – 200 * i
Line1(intDiskUsingPole(i)).X2 = 2880 + 3200 – 150 * (intDiskUsingPole(i))
Line1(intDiskUsingPole(i)).Y2 = 5160 – 200 * i
Line1(intDiskUsingPole(i)).Visible = True
Next
End Sub

‘On Solve Click do this …….
Private Sub cmdSolve_Click()
On Error GoTo ErrorHandler
NODisks = CInt(lstValues.Text)

ReDim Line1(NODisks) As Line

ReDim intDiskToPole(NODisks) As Integer
ReDim intDiskFromPole(NODisks) As Integer
ReDim intDiskUsingPole(NODisks) As Integer

Dim i As Integer

Label3.Caption = “S O L V I N G …”

txtOutput.Text = “”

For i = 1 To NODisks
intDiskFromPole(i) = i
Set Line1(i) = Controls.Add(“vb.line”, “Lin” & (i + 1))
Line1(i).BorderStyle = 6
Line1(i).BorderWidth = 10
Line1(i).BorderColor = &HC0FFFF + Hex(i) * 50
Next

intFromPtr = NODisks
intToPtr = 0
intUsingPtr = 0

For i = 1 To intFromPtr
Line1(intDiskFromPole(i)).X1 = 240 + 150 * (intDiskFromPole(i))
Line1(intDiskFromPole(i)).Y1 = 5160 – 200 * i
Line1(intDiskFromPole(i)).X2 = 2880 – 150 * (intDiskFromPole(i))
Line1(intDiskFromPole(i)).Y2 = 5160 – 200 * i
Line1(intDiskFromPole(i)).Visible = True
Next
‘If NODisks >= 1 And NODisks <= 9 Then
If MsgBox("Press Yes To Solve Tower Of Hanoi ……", vbYesNo) = vbYes Then
MousePointer = vbHourglass
SolveHanoi "Left", "Right", "Middle", NODisks
If Not StopHere Then
MousePointer = vbNormal
MsgBox "DONE!"
End If
End If
If Not StopHere Then
RemoveAllObjects
Label3.Caption = txtRules
'txtInput.Text = ""
End If
'End If
Exit Sub
ErrorHandler:
If Err.Number = 13 Or Err.Number = 9 Then
MsgBox "Please Select a proper numeric value.", vbCritical, "TOH Error"
RemoveAllObjects
Label3.Caption = txtRules
'txtInput.Text = ""
End If
End Sub

Private Sub Form_Load()
StopHere = False
Label3.Caption = "* * * * * * * * R U L E S F O R T O W E R O F H A N O I * * * * * * * " & vbCrLf & vbCrLf & vbCrLf
Label3.Caption = Label3.Caption & "A B O U T S O L V E R … " & vbCrLf & vbCrLf
Label3.Caption = Label3.Caption & "This game has 3 poles FROM, TO and USING. There are N no of Disks in the FROM pole that has to be moved to the TO pole by using the USING Pole" & vbCrLf
Label3.Caption = Label3.Caption & "In any move of the game, a given pole has to have a Larger Disk under a Smaller Disk but not vice versa" & vbCrLf
Label3.Caption = Label3.Caption & "This Solver Solves the problem in minimum possible number of transitions" & vbCrLf & vbCrLf
Label3.Caption = Label3.Caption & "P L A Y I N G T H E S O L V E R … " & vbCrLf & vbCrLf
Label3.Caption = Label3.Caption & "1. The Number Of disks has to be between 1 to 9" & vbCrLf
Label3.Caption = Label3.Caption & "2. The Solver moves disk After a small interval of approx half a sec." & vbCrLf
Label3.Caption = Label3.Caption & "3. For Larger Number of Disks the solver will take considerable amount of time. So avoid large values such as 8 or 9 for quick play. Try them otherwise" & vbCrLf
Label3.Caption = Label3.Caption & "==========================================================================================================================" & vbCrLf & vbCrLf
Label3.Caption = Label3.Caption & "Input the Number Of Disks ……. and Press 'Solve' "

'txtInput.Text = ""
lstValues.Text = "1"
txtOutput.Text = ""
txtRules = Label3.Caption
optStandard.Value = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
StopHere = True
End Sub

Sub Pause(ByVal nSecond As Single)
'nSeconds should be the number of seconds you want the Pause to last
'(may be a decimal fraction .5)
Dim StartTime As Single
StartTime = Timer
Do While Timer – StartTime < nSecond
DoEvents 'Allows you to continue interacting with the rest of your program
' if we cross midnight, back up one day
If Timer < StartTime Then
' separating the numbers stops a nasty overflow error
StartTime = StartTime – 24 * 60 * 60
End If
Loop
End Sub

Private Sub Label3_Click()

End Sub

Bound List


Option Explicit
Private Utility As New clsUtility
Private mblnValidationFailed As Boolean

Private Sub datProducts_Validate(Action As Integer, Save As Integer)
Dim strMsg As String
Dim enumMsgResult As VbMsgBoxResult

If Save = True Or Action = vbDataActionUpdate _
Or mblnValidationFailed Or Action = vbDataActionAddNew Then
‘ One or more bound controls has changed or a previous validation failed,
‘ so verify that all fields have legal entries. If a field has an incorrect
‘ value, appenda string explaining the error to strMsg and set the focus
‘ to that field to facilitate correcting the error. We explain all
‘ errors encountered in a single message box.
strMsg = “”
If txtProductName.Text = “” Then
Utility.AddToMsg strMsg, “You must enter a Product name.”
txtProductName.SetFocus
End If

If strMsg “” Then
‘ We have something in the variable strMsg, which means that an error
‘ has occurred. Display the message. The focus is in the last
‘ text box where an error was found
enumMsgResult = MsgBox(strMsg, vbExclamation + vbOKCancel + _
vbDefaultButton1)

If enumMsgResult = vbCancel Then
‘Restore the data to previous values using the data control
datProducts.UpdateControls
mblnValidationFailed = False
Else
‘ Cancel the Validate event
Action = vbDataActionCancel
‘ Deny form Unload until fields are corrected
mblnValidationFailed = True
End If
Else
mblnValidationFailed = False
End If
End If

End Sub
Private Sub Form_Unload(Cancel As Integer)

‘ Don’t allow the unload until the data is validate or the
‘ update is cancelled
If mblnValidationFailed Then Cancel = True

End Sub
Private Sub mnuDataAdd_Click()

‘ Reset all controls to the default for a new record
‘ and make space for the record in the recordset copy
‘ buffer.
datProducts.Recordset.AddNew

‘Enable the save menu choice
mnuDataSave.Enabled = True

‘ Set the focus to the first control on the form
txtProductName.SetFocus
End Sub

Private Sub mnuDataDelete_Click()
Dim strMsg As String

‘Verify the deletion.
strMsg = “Are you sure you want to delete ” _
& IIf(txtProductName.Text “”, txtProductName.Text, _
“this record”) & “?”
If MsgBox(strMsg, vbQuestion + vbYesNo + vbDefaultButton2) = vbYes Then

‘ We really want to delete
datProducts.Recordset.Delete

‘ Make a valid record the current record and update the display.
datProducts.Recordset.MoveNext

‘ If we deleted the last record, move to the new last record
‘ because the current record pointer is not defined after
‘ deleting the last record, even though EOF is defined.
If datProducts.Recordset.EOF Then datProducts.Recordset.MoveLast
End If
End Sub

Private Sub mnuDataSave_Click()

‘ Invoke the update method to copy control contents to
‘ recordset fields and update the underlying table
datProducts.Recordset.Update
If datProducts.Recordset.EditMode dbEditAdd Then

‘ If we added move to the new record
datProducts.Recordset.MoveLast
End If

End Sub

Private Sub mnuEditUndo_Click()

‘ Undo all pending changes from form by copy recordset values
‘ to form controls
datProducts.UpdateControls

If datProducts.Recordset.EditMode = dbEditAdd Then

‘ Disable the menu save and cancel the update
datProducts.Recordset.CancelUpdate
mnuDataSave.Enabled = False
End If

End Sub

Private Sub mnuFileExit_Click()

Unload Me

End Sub

Extra Time


Private Sub Command1_Click()

mDate1 = CDate(“01-06-2002 7:38 am”)

‘ Add Hour To Add TimeOut
mDate2 = DateAdd(“h”, 9, mDate1)
mDate2 = DateAdd(“s”, 1800, mDate2)

‘ Add Over Time Amount!
mDate2 = DateAdd(“h”, 3, mDate2)
mDate2 = DateAdd(“s”, 1800, mDate2) ‘ & If There Time as 3:30 Or 5:30 then for 30 Use This Line

‘ Calculate Exact Time
mHour = DateDiff(“h”, mDate1, mDate2)
mDMint = DateDiff(“n”, mDate1, mDate2)
mhMint = Round(mHour – Int((mDMint / 60)), 0)
NetHr = (mHour – mhMint)

‘ Now Add Minits In Time
mMinits = Abs((NetHr * 60) – mDMint)
NetTime = NetHr + IIf((mMinits / 100) >= 0.3, 0.5, (mMinits / 100))

OverTimeAmount = (NetTime – 9.5)

End Sub

Re-Join File


Option Explicit

Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_READ = &H80000000
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const CREATE_ALWAYS = 2
Private Const OPEN_ALWAYS = 4
Private Const INVALID_HANDLE_VALUE = -1

Private Declare Function ReadFile Lib “kernel32” _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
ByVal lpOverlapped As Long) As Long

Private Declare Function CloseHandle Lib “kernel32” _
(ByVal hObject As Long) As Long

Private Declare Function WriteFile Lib “kernel32” _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, _
ByVal lpOverlapped As Long) As Long

Private Declare Function CreateFile Lib _
“kernel32” Alias “CreateFileA” _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long

Private Declare Function FlushFileBuffers Lib “kernel32” _
(ByVal hFile As Long) As Long

Public Function JoinFiles(ByVal inputFilename As String) As _
Boolean

Dim fReadHandle As Long
Dim fWriteHandle As Long
Dim fSuccess As Long
Dim lBytesWritten As Long
Dim lBytesRead As Long
Dim ReadBuffer() As Byte
Dim TotalCount As Long
Dim Count As Integer
Dim FileName As String
Dim ret As Integer

‘ Kalau file output sudah ada
If Dir(inputFilename) <> “” Then
ret = MsgBox(“File Output (” & inputFilename & _
“) sudah ada.” & vbCrLf & _
“Akan ditindih??”, _
vbYesNo + vbQuestion, “Konfirmasi”)
If ret = vbNo Then

JoinFiles = False
Exit Function
Else
Kill inputFilename
End If
End If

Count = 1
FileName = Dir(inputFilename & “.1”)

‘No files to join
If FileName = “” Then
JoinFiles = False
Exit Function
End If

Do While FileName <> “”
Count = Count + 1
FileName = Dir(inputFilename & “.” & Count)
Loop
TotalCount = Count – 1

‘ Buka file handle untuk file yang hendak ditulisi
fWriteHandle = CreateFile(inputFilename, _
GENERIC_WRITE Or GENERIC_READ, 0, 0, _
OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)

‘ Jika sukses lanjutkan
If fWriteHandle <> INVALID_HANDLE_VALUE Then

For Count = 1 To TotalCount
‘ Buka file yang dibaca
ReDim ReadBuffer(0 To FileLen(inputFilename & “.” & Count))
fReadHandle = CreateFile(inputFilename & “.” & Count, _
GENERIC_WRITE Or GENERIC_READ, 0, 0, _
OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)

‘ Jika pembacaan sukses, lanjutkan
If fReadHandle <> INVALID_HANDLE_VALUE Then
‘ Baca blok pertama
fSuccess = ReadFile(fReadHandle, ReadBuffer(0), _
UBound(ReadBuffer), lBytesRead, 0)

‘ Tulis blok ke file
fSuccess = WriteFile(fWriteHandle, ReadBuffer(0), _
UBound(ReadBuffer), lBytesWritten, 0)

If fSuccess <> 0 Then
‘ Harus di-flush
fSuccess = FlushFileBuffers(fWriteHandle)
Else
‘ Jika ada error, keluar
JoinFiles = False
Exit Function
End If

fSuccess = CloseHandle(fReadHandle)

Else
‘ Jika ada error, keluar
JoinFiles = False
Exit Function
End If

Next Count
Else
‘ Jika ada error, keluar
JoinFiles = False
Exit Function
End If

‘ Tutup file setelah ditulis
fSuccess = CloseHandle(fWriteHandle)
JoinFiles = True

End Function

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdSplit_Click()
If JoinFiles(txtFileName.Text) Then
MsgBox “File telah berhasil di-gabung!”
Else
MsgBox “File gagal di-gabung!”
End If
End Sub

Integer.GetType


Module Module1

Const x As String = “This is a string”

Sub Main()
Dim a As Double = 5.678
Dim b As Int32 = 123

Console.WriteLine(a.ToString)
Console.WriteLine(b.ToString)
Console.WriteLine(456.987.ToString)

Dim c As Integer
Console.WriteLine(c.GetType())
Console.WriteLine(c.GetType().ToString)

End Sub

End Module