m0u53m4t
Im currently working on it. Ill post when its done. Here's the code so far:
| Code: |
| Private Sub cmdDo_Click(Index As Integer)
Static Solution(1 To 9, 1 To 9) As Variant Static PossibleValues(1 To 10) As Integer Static boxres(1 To 9) As Integer Dim x As Integer Dim y As Integer Dim x2 As Integer Dim y2 As Integer Dim x3 As Integer Dim y3 As Integer Dim xbox As Integer Dim ybox As Integer Dim poss As Integer Dim boxes As Integer Dim currenthighest As Integer Dim highestbox As Integer Dim highestcell As Integer Dim valcount As Integer Dim z As Integer Dim m As Integer Dim n As Integer Dim CurrentNo As Integer Dim currentbox As Integer Dim answer As Integer Dim strSQL As String Dim rs As ADODB.Recordset Dim cn As ADODB.Connection Dim loaded As Integer Set cn = New ADODB.Connection cn.ConnectionString = "Provider=MSDASQL.1;Persist Security Info=False;Data Source=Sudoku" cn.Open Select Case Index Case Is = 1: 'Load If loaded = 1 Then Else loaded = 0 cmdDo(0).Enabled = True cmdDo(2).Enabled = True adoProblems.Recordset.MoveFirst For y = 1 To 9 'For the vertical column For x = 1 To 9 ' For the horisontal row Solution(y, x) = PossibleValues() For poss = 1 To 10 'Repeat for 123456789 If poss = 10 Then Select Case x: 'Writing from table to array Case Is = 1: Solution(y, x)(poss) = Val(adoProblems.Recordset!Col1 & "") Case Is = 2: Solution(y, x)(poss) = Val(adoProblems.Recordset!Col2 & "") Case Is = 3: Solution(y, x)(poss) = Val(adoProblems.Recordset!Col3 & "") Case Is = 4: Solution(y, x)(poss) = Val(adoProblems.Recordset!Col4 & "") Case Is = 5: Solution(y, x)(poss) = Val(adoProblems.Recordset!Col5 & "") Case Is = 6: Solution(y, x)(poss) = Val(adoProblems.Recordset!Col6 & "") Case Is = 7: Solution(y, x)(poss) = Val(adoProblems.Recordset!Col7 & "") Case Is = 8: Solution(y, x)(poss) = Val(adoProblems.Recordset!Col8 & "") Case Is = 9: Solution(y, x)(poss) = Val(adoProblems.Recordset!Col9 & "") End Select If Not Solution(y, x)(10) = 0 Then 'If pos 10 has a value For z = 1 To 9 CurrentNo = Solution(y, x)(10) Solution(y, x)(z) = 0 ' Wipe all positions (ex. 10) Next z Solution(y, x)(CurrentNo) = CurrentNo 'Put back right position End If Else Solution(y, x)(poss) = poss ' write poss to position poss End If Next poss Next x adoProblems.Recordset.MoveNext Next y 'Completed one pass through whole grid (filled array) For y = 1 To 9 For x = 1 To 9 ' If y = 7 And x = 1 Then ' MsgBox "" ' End If If Solution(y, x)(10) > 0 Then CurrentNo = Solution(y, x)(10) For y2 = 1 To 9 If Not y = y2 Then Solution(y2, x)(CurrentNo) = 0 'Wipe out all occurences in column End If Next y2 For x2 = 1 To 9 If Not x = x2 Then Solution(y, x2)(CurrentNo) = 0 'Wipe out all occurences in row End If Next x2 If x <= 3 Then xbox = 1 If x > 3 And x < 7 Then xbox = 2 If x > 6 Then xbox = 3 If y <= 3 Then ybox = 1 If y > 3 And y < 7 Then ybox = 2 If y > 6 Then ybox = 3 ' Find out which xbox and ybox the cell is in For m = 0 To 2 For n = 0 To 2 Solution((ybox * 3) - n, (xbox * 3) - m)(CurrentNo) = 0 Next n Next m Solution(y, x)(CurrentNo) = CurrentNo Else CurrentNo = 0 End If Next x Next y End If Case Is = 0: 'Solve For y3 = 1 To 9 For x3 = 1 To 9 valcount = 0 answer = 0 If Solution(y3, x3)(10) = 0 Then 'Not yet established a value For m = 1 To 9 If Solution(y3, x3)(m) = 0 Then valcount = valcount + 1 Else answer = Solution(y3, x3)(m) End If Next m If valcount = 8 Then Solution(y3, x3)(10) = answer cn.BeginTrans strSQL = "Update PROBLEMS " & _ "Set Col" & x3 & " = '" & answer & "' " & _ "Where Row = '" & y3 & "'" Debug.Print (strSQL) cn.Execute strSQL cn.CommitTrans For y2 = 1 To 9 If y3 = y2 Then Else Solution(y2, x3)(answer) = 0 'Wipe out all occurences in column End If Next y2 For x2 = 1 To 9 If x3 = x2 Then Else Solution(y3, x2)(answer) = 0 'Wipe out all occurences in row End If Next x2 If x3 <= 3 Then xbox = 1 If x3 > 3 And x3 < 7 Then xbox = 2 If x3 > 6 Then xbox = 3 If y3 <= 3 Then ybox = 1 If y3 > 3 And y3 < 7 Then ybox = 2 If y3 > 6 Then ybox = 3 ' Find out which xbox and ybox the cell is in For m = 0 To 2 For n = 0 To 2 Solution((ybox * 3) - n, (xbox * 3) - m)(answer) = 0 Next n Next m Solution(y3, x3)(answer) = answer End If End If Next x3 Next y3 End Select adoProblems.Refresh End Sub |
