发信人: kingywq()
整理人: gzwsh(2002-11-05 22:59:39), 站内信件
|
我用VB 6编了一个螺旋方阵的解法，可求解任意阶的螺旋方阵，只受限于
机器的性能和容量。
以下是我的原代码，有些注释还需时间整理。
以下是frmMain的代码:
Private lMin As Long
Private lMax As Long
Private lIncrement As Long
Private iRank As Integer
Private Sub Init()
lMin = 1
lMax = 4
lIncrement = 1
iRank = 2
End Sub
Private Function Format_Long(sValue As String, lMin As Long, lMax As Long, sMsg As String, sTitle As String, ByRef ctlText As TextBox) As Integer
On Error GoTo HandleError
Dim lTemp As Long
If sValue = "" Then
MsgBox sMsg, vbCritical + vbOKOnly, sTitle
ctlText.SetFocus
ctlText.SelStart = 1
ctlText.SelLength = Len(sValue)
Else
If IsNumeric(sValue) = False Then
MsgBox sMsg, vbCritical + vbOKOnly, sTitle
ctlText.SetFocus
ctlText.SelStart = 0
ctlText.SelLength = Len(sValue)
Else
lTemp = CLng(sValue)
If lMax > -1 Then
If Not (lTemp >= lMin And lTemp <= lMax) Then
MsgBox sMsg, vbCritical + vbOKOnly, sTitle
ctlText.SetFocus
ctlText.SelStart = 0
ctlText.SelLength = Len(sValue)
Else
Format_Long = lTemp
End If
Else
If Not lTemp >= lMin Then
MsgBox sMsg, vbCritical + vbOKOnly, sTitle
ctlText.SetFocus
ctlText.SelStart = 0
ctlText.SelLength = Len(sValue)
Else
Format_Long = lTemp
End If
End If
End If
End If
Exit Function
HandleError:
MsgBox "发生了错误号为" + CStr(Err.Number) + "的" + Err.Description + "错误，程序将退出，请检查所输入参数是否正确", vbCritical + vbOKOnly, "严重错误"
End
End Function
Private Function Check_Validate(ByVal lMin As Integer, ByVal lMax As Integer, ByVal lIncrement As Integer, ByVal iRank As Integer, ByVal sMsg As String, ByVal sTitle As String) As Boolean
On Error GoTo HandleError
If lMax = lMin + (iRank * iRank - 1) * lIncrement Then
Check_Validate = True
Else
MsgBox sMsg, vbInformation + vbOKOnly, stile
Check_Validate = False
End If
Exit Function
HandleError:
MsgBox "发生了错误号为" + CStr(Err.Number) + "的" + Err.Description + "错误，程序将退出，请检查所输入参数是否正确", vbCritical + vbOKOnly, "严重错误"
End
End Function
Private Sub cmdClear_Click()
frmResult.txtResult.Text = ""
End Sub
Private Sub cmdCreate_Click()
Dim cPhalanx As clsPhalanx
Dim aryPhalanx() As Long
Dim bReturn As Boolean
Dim iLoop1, iLoop2 As Integer
Dim sResult, sTemp As String
If Check_Validate(lMin, lMax, lIncrement, iRank, "所输入参数不能形成一个旋转方阵，请检查", "参数错误") = False Then
txtMin.SetFocus
txtMin.SelStart = 0
txtMin.SelLength = Len(txtMin.Text)
Else
Set cPhalanx = New clsPhalanx
cPhalanx.Min = lMin
cPhalanx.Max = lMax
cPhalanx.Increment = lIncrement
cPhalanx.Rank = iRank
' ReDim aryPhalanx(iRank, iRank) As Long
bReturn = cPhalanx.getPhalanx(aryPhalanx)
If bReturn = False Then
MsgBox "计算时发生错误，请检查或联系作者", vbCritical + vbOKOnly, "错误"
End
End If
frmResult.Show
sResult = "方阵阶数：" + CStr(iRank) + vbCrLf
For iLoop1 = 1 To iRank
For iLoop2 = 1 To iRank
sTemp = Trim(CStr(aryPhalanx(iLoop1, iLoop2)))
sResult = sResult + sTemp + Space(Len(Trim(CStr(lMax))) + 5 - Len(sTemp))
Next iLoop2
sResult = sResult + vbCrLf
Next iLoop1
frmResult.txtResult.Text = frmResult.txtResult.Text + vbCrLf + vbCrLf + sResult
End If
End Sub
Private Sub Form_Load()
Init
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub txtMin_LostFocus()
txtMin.Text = Trim(txtMin.Text)
lMin = Format_Long(txtMin.Text, 1, -1, "请输入正确的起始数值，起始数值为填入方阵的最小整数", "参数错误", txtMin)
txtMin.Text = CStr(lMin)
End Sub
Private Sub txtMax_LostFocus()
txtMax.Text = Trim(txtMax.Text)
lMax = Format_Long(txtMax.Text, 1, -1, "请输入正确的结束数值，起始数值为填入方阵的最大整数", "参数错误", txtMax)
txtMax.Text = CStr(lMax)
End Sub
Private Sub txtIncrement_LostFocus()
txtIncrement.Text = Trim(txtIncrement.Text)
lIncrement = Format_Long(txtIncrement.Text, 1, -1, "请输入正确的间隔值，间隔值是方阵中相邻两个数间的间隔", "参数错误", txtIncrement)
txtIncrement.Text = CStr(lIncrement)
End Sub
Private Sub txtRank_LostFocus()
txtRank.Text = Trim(txtRank.Text)
iRank = Format_Long(txtRank.Text, updRank.Min, updRank.Max, "请输入正确的方阵大小值，方阵大小值是方阵的阶数", "参数错误", txtRank)
txtRank.Text = CStr(iRank)
End Sub
Private Sub updRank_Change()
iRank = CInt(txtRank.Text)
End Sub
以下是类clsPhalanx的代码：
Option Explicit
'保持属性值的局部变量
Private mvarMin As Long '局部复制
Private mvarMax As Long '局部复制
Private mvarIncrement As Long '局部复制
Private mvarRank As Integer '局部复制
Private maryInput() As Long '保存传入的参数数组或由mvarMin,mvarMax,mvarIncrement,mvarRank形成的初始数组
Private maryResult() As Long '保存处理后的结果数组
Private mbUseArray As Boolean '是否用setArray传入参数数组
'检查参数是否可以组成一个方阵
Private Sub Check()
On Error GoTo HandleError
If mbUseArray = False Then
If mvarMax <> mvarMin + (mvarRank * mvarRank - 1) * mvarIncrement Then
MsgBox "所给参数不能形成一个方阵，请检查。", vbOKOnly + vbCritical, "严重错误"
End
End If
End If
Exit Sub
HandleError:
MsgBox "发生了错误代码为" + CStr(Err.Number) + "的" + Err.Description + "的错误，程序将退出，请检查所参数是否正确或联系作者。", vbCritical + vbOKOnly, "严重错误"
End
End Sub
'由mvarMin,mvarMax,mvarIncrement,mvarRank组成一个初始数组
Private Sub Init()
On Error GoTo HandleError
Dim iLoop As Integer
If mbUseArray = False Then
ReDim maryInput(1 To mvarRank * mvarRank) As Long
ReDim maryResult(1 To mvarRank, 1 To mvarRank) As Long
For iLoop = 1 To mvarRank * mvarRank
maryInput(iLoop) = mvarMin + (iLoop - 1) * mvarIncrement
Next iLoop
End If
Exit Sub
HandleError:
MsgBox "发生了错误代码为" + CStr(Err.Number) + "的" + Err.Description + "的错误，程序将退出，请检查所参数是否正确或联系作者。", vbCritical + vbOKOnly, "严重错误"
End
End Sub
'这是一个递归函数
'是程序的核心部分，对数组进行处理，形成旋转方阵
Private Sub Caculate(iRank As Integer)
On Error GoTo HandleError
Dim iTemp, iTemp1, iTemp2, iTemp3, iLoop As Integer
'假设有如下mvarRank*mvarRank阶的方阵
'
'
' * ... * * * * * * * ... *
' * ... *
' * A * * * * B C ... *
' * H * ... *
' * * * ... *
' * * ... * ... *
' * * * ... *
' * * D ... *
' * G F * * * * E ... *
' * ... *
' * ... * * * * * * * ... *
'
'
'以上是递归循环到阶数iRank时的方阵
'A...B C...D E...F G...H表示当前循环要填入数字的位置
'A在方阵中的位置应为(iTemp,iTemp)，iTemp的值为(mvarRank - iRank) / 2 + 1
'C在方阵中的位置应为(iTemp,iTemp+iRank-1)
'E在方阵中的位置应为(iTemp+iRank-1,iTemp+iRank-1)
'G在方阵中的位置应为(iTemp+iRank-1,iTemp)
'当前iRank阶循环的内部（不包括外围）的元素个数为(iRank-2)*(iRank-2)
'因此，位置H处应填入maryInput(iTemp1)，iTemp1的值为mvarRank * mvarRank - (iRank - 2) * (iRank - 2)
'其他位置应填入的值的情况请参看程序
'
'
'
If iRank = 1 Then '递归的终结条件之一，当当前要处理的阶数为1时
iTemp = (mvarRank + 1) / 2
maryResult(iTemp, iTemp) = maryInput(mvarRank * mvarRank)
ElseIf iRank = 2 Then '递归的终结条件之一，当当前要处理的阶数为2时
iTemp = mvarRank / 2
maryResult(iTemp, iTemp) = maryInput(mvarRank * mvarRank - 3)
maryResult(iTemp, iTemp + 1) = maryInput(mvarRank * mvarRank - 2)
maryResult(iTemp + 1, iTemp + 1) = maryInput(mvarRank * mvarRank - 1)
maryResult(iTemp + 1, iTemp) = maryInput(mvarRank * mvarRank)
Else '如果当前要处理的阶数大于2
iTemp = (mvarRank - iRank) / 2 + 1
iTemp1 = mvarRank * mvarRank - (iRank - 2) * (iRank - 2)
'填充位置A至B
iTemp2 = (iRank - 1) * 4 - 1
iTemp3 = iTemp1 - iTemp2
For iLoop = 1 To iRank - 1
maryResult(iTemp, iTemp + iLoop - 1) = maryInput(iTemp3 + iLoop - 1)
Next iLoop
'填充位置C至D
iTemp2 = (iRank - 1) * 3 - 1
iTemp3 = iTemp1 - iTemp2
For iLoop = 1 To iRank - 1
maryResult(iTemp + iLoop - 1, iTemp + iRank - 1) = maryInput(iTemp3 + iLoop - 1)
Next iLoop
'填充位置E至F
iTemp2 = (iRank - 1) * 2 - 1
iTemp3 = iTemp1 - iTemp2
For iLoop = 1 To iRank - 1
maryResult(iTemp + iRank - 1, (iTemp + iRank - 1) - (iLoop - 1)) = maryInput(iTemp3 + iLoop - 1)
Next iLoop
'填充位置G至H
iTemp2 = (iRank - 1) * 1 - 1
iTemp3 = iTemp1 - iTemp2
For iLoop = 1 To iRank - 1
maryResult((iTemp + iRank - 1) - (iLoop - 1), iTemp) = maryInput(iTemp3 + iLoop - 1)
Next iLoop
'递归调用
Caculate (iRank - 2)
End If
Exit Sub
HandleError:
MsgBox "发生了错误代码为" + CStr(Err.Number) + "的" + Err.Description + "的错误，请检查或联系作者。", vbCritical + vbOKOnly, "严重错误"
End
End Sub
'返回处理后的结果方阵数组
Public Function getPhalanx(ByRef aryResult() As Long) As Boolean
On Error GoTo HandleError
Dim iLoop1, iLoop2 As Integer
Check
Init
Caculate (mvarRank)
ReDim aryResult(mvarRank, mvarRank) As Long
'拷贝结果数组各元素之值到返回数组中
For iLoop1 = 1 To mvarRank
For iLoop2 = 1 To mvarRank
aryResult(iLoop1, iLoop2) = maryResult(iLoop1, iLoop2)
Next iLoop2
Next iLoop1
getPhalanx = True '返回值为真表示调用成功
Exit Function
HandleError:
MsgBox "发生了错误代码为" + CStr(Err.Number) + "的" + Err.Description + "的错误，请检查或联系作者。", vbCritical + vbOKOnly, "严重错误"
getPhalanx = False
End Function
'将要处理的数组作为参数传入，这样就具有很好的可扩展性
Public Function setArray(ByRef aryInput() As Long, iRank As Integer) As Boolean
On Error GoTo HandleError
Dim iLoop1, iLoop2 As Integer
If UBound(aryInput, 1) = iRank And UBound(aryInput, 2) = iRank Then
ReDim maryInput(1 To iRank, 1 To iRank) As Long
For iLoop1 = 1 To iRank
For iLoop2 = 1 To iRank
maryInput(iLoop1, iLoop2) = aryInput(iLoop1, iLoop2)
Next iLoop2
Next iLoop1
mvarRank = iRank
mbUseArray = True
setArray = True
Else
MsgBox "所传入数组不能组成方阵，请检查。", vbCritical + vbOKOnly, "错误"
setArray = False
End If
Exit Function
HandleError:
MsgBox "发生了错误代码为" + CStr(Err.Number) + "的" + Err.Description + "的错误，请检查参数或与作者联系。", vbCritical + vbOKOnly, "严重错误"
setArray = False
End Function
Public Property Let Rank(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Rank = 5
If vData < 2 Then
MsgBox "方阵的阶数应大于等于2，请检查参数", vbCritical + vbOKOnly, "错误"
End
Else
mvarRank = vData
End If
End Property
Public Property Get Rank() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Rank
Rank = mvarRank
End Property
Public Property Let Increment(ByVal vData As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Increment = 5
mvarIncrement = vData
End Property
Public Property Get Increment() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Increment
Increment = mvarIncrement
End Property
Public Property Let Max(ByVal vData As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Max = 5
mvarMax = vData
End Property
Public Property Get Max() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Max
Max = mvarMax
End Property
Public Property Let Min(ByVal vData As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Min = 5
mvarMin = vData
End Property
Public Property Get Min() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Min
Min = mvarMin
End Property
Private Sub Class_Initialize()
mvarMin = 1
mvarMax = 4
mvarIncrement = 1
mvarRank = 2
mbUseArray = False
End Sub
若要整个程序，请发E-MAIL至[email protected]。
希望能对你有所帮助。
|
|