' Construct Order 17 Quadrant Magic Patterns (Bordered)
' Public Area's declared in Module4 (ChkPtrn17)
' Routines P01 ... P253 contain the equations describing the correponding pattern
' (not available in HTML)
' Tested with Office 365 under Windows 10
Sub ChkPtrn17a()
Dim Pnm17(7)
y = MsgBox("Blocked", vbInformation, "ChkPtrn17a")
End
ShtNm1 = "CntrSqrs13" 'Input
ShtNm2 = "Klad1" 'Print Quadrant Count
k1 = 1: k2 = 1
Pnm17(1) = "P61": Pnm17(2) = "P140": Pnm17(3) = "P143": Pnm17(4) = "P144":
Pnm17(5) = "P147": Pnm17(6) = "P148": Pnm17(7) = "P154":
Sheets(ShtNm2).Select
For j100 = 2 To 5761
Cells(1, 1).Value = j100
For i1 = 1 To 289 'Read available Square(s)
a(i1) = Sheets(ShtNm1).Cells(j100, i1).Value
Next i1
GoSub 700: If fl1 = 0 Then GoTo 1000 'Check Magic Patterns (Center Squares)
nStr13 = ""
For i1 = 1 To 7
If nQ(i1) = 4 Then
nStr13 = nStr13 + Pnm17(i1) + " "
End If
Next i1
If nStr13 = "" Then GoTo 1000
GoSub 1250 'Define (fixed) Border
GoSub 300: If fl1 = 0 Then GoTo 1000 'Check Identical Numbers (Back Check)
n9 = n9 + 1: GoSub 670 'Print Square
1000 Next j100
End
' Check Identical Numbers a()
300 fl1 = 1
For i1 = 1 To 289
a20 = a(i1)
For i2 = (1 + i1) To 289
If a20 = a(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Print a(), squares
670 n1 = n1 + 1
If n1 = 2 Then
n1 = 1: k1 = k1 + 18: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 18
End If
Cells(2, 1).Value = n9
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Value = nStr13
i3 = 0
For i1 = 1 To 17
For i2 = 1 To 17
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
' Check Magic Patterns (Testing)
700 fl1 = 1: Erase nP, nQ, s
P61 1
P140 2
P143 3
P144 4
P147 5
P148 6
P154 7
Return
1250
' Fixed Border 15 x 15
a(19) = 26: a(20) = 20: a(21) = 21: a(22) = 260: a(23) = 261: a(24) = 262: a(25) = 25:
a(26) = 27: a(27) = 266: a(28) = 267: a(29) = 268: a(30) = 31: a(31) = 32: a(32) = 271:
a(33) = 138:
a(36) = 36: a(50) = 254:
a(53) = 135: a(67) = 155:
a(70) = 67: a(84) = 223:
a(87) = 169: a(101) = 121:
a(104) = 70: a(118) = 220:
a(121) = 118: a(135) = 172:
a(138) = 186: a(152) = 104:
a(155) = 87: a(169) = 203:
a(172) = 189: a(186) = 101:
a(189) = 240: a(203) = 50:
a(206) = 206: a(220) = 84:
a(223) = 257: a(237) = 33:
a(240) = 237: a(254) = 53:
a(257) = 152: a(258) = 270: a(259) = 269: a(260) = 30: a(261) = 29: a(262) = 28: a(263) = 265:
a(264) = 263: a(265) = 24: a(266) = 23: a(267) = 22: a(268) = 259: a(269) = 258: a(270) = 19:
a(271) = 264:
' Fixed Border 17 x 17
a(1) = 9: a(2) = 2: a(3) = 3: a(4) = 4: a(5) = 277: a(6) = 278: a(7) = 279:
a(8) = 280: a(9) = 282: a(10) = 283: a(11) = 284: a(12) = 285: a(13) = 14: a(14) = 15:
a(15) = 16: a(16) = 17: a(17) = 137:
a(18) = 18: a(34) = 272:
a(35) = 35: a(51) = 255:
a(52) = 52: a(68) = 238:
a(69) = 69: a(85) = 221:
a(86) = 102: a(102) = 188:
a(103) = 119: a(119) = 171:
a(120) = 136: a(136) = 154:
a(137) = 170: a(153) = 120:
a(154) = 187: a(170) = 103:
a(171) = 204: a(187) = 86:
a(188) = 205: a(204) = 85:
a(205) = 222: a(221) = 68:
a(222) = 239: a(238) = 51:
a(239) = 256: a(255) = 34:
a(256) = 289: a(272) = 1:
a(273) = 153: a(274) = 288: a(275) = 287: a(276) = 286: a(277) = 13: a(278) = 12: a(279) = 11:
a(280) = 10: a(281) = 8: a(282) = 7: a(283) = 6: a(284) = 5: a(285) = 276: a(286) = 275:
a(287) = 274: a(288) = 273: a(289) = 281:
Return
End Sub
Sub Cnt17(i1) 'Count Patterns
s1 = 2465 'Magic Constant
For i2 = 1 To 4
If s(i2) = s1 Then nP(i1, i2) = 1: nQ(i1) = nQ(i1) + 1
Next i2
End Sub
