[VB6][VBA]製作一個魔術方陣的大量產生器

2011-08-08

5201
0
VB6
2011-08-08

你一定試過建立一個數字方陣，條件是要各橫、直、斜線上的數字總和相等。
其實這是有方法的，以 5x5 方陣為例：
1. 先決定數字進行的距離和方位的二個向量。
  1. 第一向量 x,y 都要變動例如： x=x+1, y=y-1 。
  2. 第二向量只變更一個軸例如：x=x+2, y=y+1 。
2. 任選一個位置（例如 : 3,2 ）填１。
3. 那麼下一個數字２就填在（3+1, 2-1）的地方（4, 1）然後繼續填下個數字。
4. 如果遇到下面情況：
  1. 若 x 或 y 超出方陣：取邊長的補數。
  2. 若新位置上已有數字時：依第二向量取得替代位置。
  3. 若新位置的 x, y 同時超出方陣時則視為該位置已有數字，依第二向量處理。
5. 重複同樣規則把數字填完。

這樣說明可能還是不很清楚，請看下圖：

１的位置在 (3,2)
２的位置在 (3+1,2-1)→(4, 2)
３的位置在 (4+1, 2-1)→(5, 0)→超出方陣修正為→(5,5)
４的位置在 (5+1,5-1)→(6, 4)→超出方陣修正為→(1, 4)
５的位置在 (1+1, 4-1)→(2, 3)
６的位置在 (2+1, 3-1)→(3, 2))→修正為→(3+2, 2+1)→(5, 3)
７的位置在 (5+1, 3-1)→(6, 2)→超出方陣修正為→(1, 2)
同上………

教學時曾依前述方法寫了一個程式，輸入條件後可以大量產生這樣的方陣，並且直接輸出報表檔。
以下是用程式跑的結果：

設邊長為 7, 居然有 25272 個。產生報表檔。

VB6 的程式碼（太佔篇幅只貼方陣產生的函式，完整程式碼可自行下載）（VB.net 要改一下才能執行）


'-----------------------------------
'   n = 邊長。
'  mX = 下一位置的 X 增量。
'  mY = 下一位置的 Y 增量。
'  sX = 遇重疊時下一位置的 X 增量。
'  sY = 遇重疊時下一位置的 Y 增量。
'-----------------------------------
Function 方陣(n, mX, mY, sX, sY)
    For q = stx0 To stx1
        For r = sty0 To sty1
            ReDim aa(n, n)
            x = q: y = r
            For i = 1 To n ^ 2
                aa(x, y) = i
                
                '依ｘ和ｙ的增量，將定位點移動到下個預定位置。
                If 中斷 Then Exit For
                x = x + mX
                y = y + mY
                FixXY n
                
                '預定位置已有數字時的處理
                If aa(x, y) <> 0 Then x = x + sX: y = y + sY: FixXY n
            Next
            '查驗各行列及對角線的 Sum
            Sum = n * (n ^ 2 + 1) / 2
            chk = 0: X1 = 0: X2 = 0
            For i = 1 To n
                If 中斷 Then Exit For
                X1 = X1 + aa(i, i)
                X2 = X2 + aa(n + 1 - i, i)
                cSum = 0: rSum = 0
                For j = 1 To n
                    If 中斷 Then Exit For
                    DoEvents
                    cSum = cSum + aa(i, j)
                    rSum = rSum + aa(j, i)
                Next
                If cSum <> Sum Or rSum <> Sum Then j = n: i = n: chk = 1
            Next
            If X1 <> Sum Or X2 <> Sum Then chk = 1
            '若驗證通過即印出結果
            If chk = 0 Then
                cnt = cnt + 1
                t = Len(Str(n * n)) + 1
                tmp = "NO: " & cnt & vbCrLf
                tmp = tmp & "Sum=" & Sum & " st(" & x & "," & y & ") x(" & mX & ") y(" & mY & ") sx(" & sX & ") sy(" & sY & ")" & vbCrLf
                For i = 1 To n
                    If 中斷 Then Exit For
                    For j = 1 To n
                        If 中斷 Then Exit For
                        DoEvents
                        tmp = tmp & String(t - Len(aa(j, i)), " ") & aa(j, i)
                    Next
                    tmp = tmp & vbCrLf
                Next
                tmp = tmp & vbCrLf
                ReDim b(Len(tmp)) As Byte
                b = StrConv(tmp, vbFromUnicode)
                If 中斷 Then
                    q = stx1: r = stx0: Close #fi
                Else
                    Put #fi, , b
                End If
            End If
        Next
    Next
End Function


Function FixXY(n)
    If y > n Then y = y - n
    If y < 1 Then y = y + n
    If x > n Then x = x - n
    If x < 1 Then x = x + n
End Function

Private Sub lbl_輸出位置_Click()
    If lbl_輸出位置 <> "" Then
        ShellExecute Me.hWnd, "open", "explorer.exe", "/select," & lbl_輸出位置, vbNullString, vbNormalFocus
    End If
End Sub

VB6 原始碼下載：解魔術方陣.rar

ku3

回首頁

設邊長為 7, 居然有 25272 個。	產生報表檔。