سلام
من میخواستم اگه کسی میتونه برای این برنامه یک Inpubox یا یکTextBox قرار بده که کابر تعداده حلقه ها را انتخاب کنه مثلا نوشت 10 ,10تا حلقه در TowerAقرار بگیره ممنون میشم اگه کمک کنید
ببین برنامه شما از رویداد Form_Load شروع می شود.
برای تغییر اون قسمت را بیار در رویداد کلیک یک دکمه.
که در همین رویداد کلیک دکمه تکست باکس ها را می خواند یا input می گیرد.
ولی یک مشکل:
من در همان رویداد فرم لود که اعداد را عوض کردم برنامه به هم ریخت.
یعنی فکر کنم شما باید کل برنامه را درک کنید و کلش را تغییر دهید.
'Author: VInit Sankhe
'A Tower of Hanoi Solver
'Developed on: 7 June 2004
'Updated on: 14th June 2004
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
وقتی داشتم ریپلیس را می گفتم در چت برق رفت. تقریبا 45 دقیقه بعد آمد. بعدش تا الان که یک و نیم نیمه شب است منتظرم . Idle هستی.
نمی دونم اومد که چی را جایگزین کنی. text1 بود.
خیلی سخته من تازه کارم
