ToolTipText = "Left: Send Mail to Author Right: Show About"
Top = 90
Width = 675
End
Begin VB.Label lbTime
Alignment = 2 'Zentriert
BackColor = &H00000000&
BackStyle = 0 'Transparent
Height = 885
Left = 4965
TabIndex = 7
Top = 3195
Width = 1410
End
Begin VB.Label lb
BackColor = &H00000000&
BackStyle = 0 'Transparent
Caption = "Puzzle"
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000080&
Height = 360
Index = 0
Left = 2085
TabIndex = 6
Top = 135
Width = 945
End
Begin VB.Label lb
BackColor = &H00000000&
BackStyle = 0 'Transparent
Caption = "Solution"
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00008000&
Height = 360
Index = 1
Left = 8205
TabIndex = 5
Top = 135
Width = 1155
End
Begin VB.Shape sh
BorderColor = &H00000080&
BorderWidth = 3
Height = 1500
Index = 0
Left = 330
Top = 555
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00000080&
BorderWidth = 3
Height = 1500
Index = 1
Left = 330
Top = 2040
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00000080&
BorderWidth = 3
Height = 1500
Index = 2
Left = 330
Top = 3525
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00000080&
BorderWidth = 3
Height = 1500
Index = 3
Left = 1815
Top = 3525
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00000080&
BorderWidth = 3
Height = 1500
Index = 4
Left = 1815
Top = 2040
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00000080&
BorderWidth = 3
Height = 1500
Index = 5
Left = 1815
Top = 555
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00000080&
BorderWidth = 3
Height = 1500
Index = 6
Left = 3300
Top = 3525
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00000080&
BorderWidth = 3
Height = 1500
Index = 7
Left = 3300
Top = 2040
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00000080&
BorderWidth = 3
Height = 1500
Index = 8
Left = 3300
Top = 555
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00000080&
BorderWidth = 2
Height = 4515
Index = 9
Left = 315
Top = 540
Width = 4515
End
Begin VB.Shape sh
BorderColor = &H00008000&
BorderWidth = 3
Height = 1500
Index = 11
Left = 9525
Top = 555
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00008000&
BorderWidth = 3
Height = 1500
Index = 12
Left = 9525
Top = 2040
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00008000&
BorderWidth = 3
Height = 1500
Index = 13
Left = 9525
Top = 3525
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00008000&
BorderWidth = 3
Height = 1500
Index = 14
Left = 8040
Top = 555
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00008000&
BorderWidth = 3
Height = 1500
Index = 15
Left = 8040
Top = 2040
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00008000&
BorderWidth = 3
Height = 1500
Index = 16
Left = 8040
Top = 3525
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00008000&
BorderWidth = 3
Height = 1500
Index = 17
Left = 6555
Top = 3525
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00008000&
BorderWidth = 3
Height = 1500
Index = 18
Left = 6555
Top = 2040
Width = 1500
End
Begin VB.Shape sh
BorderColor = &H00008000&
BorderWidth = 3
Height = 1500
Index = 19
Left = 6555
Top = 555
Width = 1500
End
Begin VB.Label lb
BackColor = &H00000000&
BackStyle = 0 'Transparent
Caption = "Puzzle"
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 360
Index = 2
Left = 2070
TabIndex = 8
Top = 120
Width = 945
End
Begin VB.Label lb
BackColor = &H00000000&
BackStyle = 0 'Transparent
Caption = "Solution"
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 360
Index = 3
Left = 8190
TabIndex = 9
Top = 120
Width = 1155
End
Begin VB.Shape sh
BorderColor = &H00008000&
BorderWidth = 2
Height = 4515
Index = 10
Left = 6540
Top = 540
Width = 4515
End
Begin VB.Shape shBg
BorderColor = &H00808080&
FillColor = &H00E8E8D0&
FillStyle = 0 'Ausgefⁿllt
Height = 2460
Left = 4965
Top = 1920
Visible = 0 'False
Width = 1410
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuLoad
Caption = "&Load Puzzle..."
Shortcut = {F5}
End
Begin VB.Menu mnuSavePuz
Caption = "Save &Puzzle As..."
Shortcut = {F6}
End
Begin VB.Menu mnuSaveSol
Caption = "Save &Solution As..."
Shortcut = {F7}
End
Begin VB.Menu sep0
Caption = "-"
End
Begin VB.Menu mnuPrintPuz
Caption = "Print P&uzzle"
Shortcut = ^P
End
Begin VB.Menu mnuPrintSol
Caption = "Print S&olution"
Shortcut = ^S
End
Begin VB.Menu sep1
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "Exit"
Shortcut = {F3}
End
End
Begin VB.Menu mnuOptions
Caption = "&Options"
Begin VB.Menu mnuVoice
Caption = "Voice"
Checked = -1 'True
End
Begin VB.Menu sep4
Caption = "-"
End
Begin VB.Menu mnuAnimate
Caption = "&Animate"
Begin VB.Menu mnuAnimSpeed
Caption = "Off"
Checked = -1 'True
Index = 0
End
Begin VB.Menu mnuAnimSpeed
Caption = "Slow"
Index = 1
End
Begin VB.Menu mnuAnimSpeed
Caption = "Medium"
Index = 2
End
Begin VB.Menu mnuAnimSpeed
Caption = "Fast"
Index = 3
End
End
Begin VB.Menu mnuHide
Caption = "&Hide"
Shortcut = {F9}
End
Begin VB.Menu sep2
Caption = "-"
End
Begin VB.Menu mnuClear
Caption = "&Clear"
Shortcut = ^C
End
Begin VB.Menu mnuSolve
Caption = "&Solve"
End
End
Begin VB.Menu mnuQ
Caption = "&?"
Begin VB.Menu mnuAbout
Caption = "&About"
Shortcut = {F1}
End
Begin VB.Menu mnuSendMail
Caption = "&Send Mail"
Shortcut = {F2}
End
End
End
Attribute VB_Name = "fMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Sub InitCommonControls Lib "comctl32" () ':) Line inserted by Formatter
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function Beeper Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, ByRef nSize As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qRC As tRect, ByVal Edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function PutFocus Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal ByPos As Long, lpcMenuItemInfo As MENUITEMINFO) As Long
Private HscFrequ As Currency 'high speed counter frequency - using currency type as 64bit-doublelong
Private StartTick As Currency
Private EndTick As Currency
Private Correction As Currency
Private DelayStart As Currency
Private DelayEnds As Currency
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Private MII As MENUITEMINFO
Private Type tRect
L As Long
t As Long
r As Long
b As Long
End Type
Private RECT As tRect
Private Enum ApiConstants
BDR_RAISEDOUTER = 1
BDR_SUNKENOUTER = 2
BDR_RAISEDINNER = 4
BDR_SUNKENINNER = 8
BDR_FILLET = BDR_RAISEDOUTER Or BDR_SUNKENINNER
BDR_RIDGE = BDR_SUNKENOUTER Or BDR_RAISEDINNER
BDR_RAISED = BDR_RAISEDOUTER Or BDR_RAISEDINNER
BDR_SUNKEN = BDR_SUNKENOUTER Or BDR_SUNKENINNER
BF_RECT = 15
BF_MONO = &H8000
SW_SHOWNORMAL = 1
SE_NO_ERROR = 33 'Values below 33 are error returns
CS_DROPSHADOW = &H20000
GCL_STYLE = -26
REALTIME_PRIORITY_CLASS = &H100
MFS_DEFAULT = &H1000
MIIM_STATE = 1
End Enum
Private Vox As SpVoice
Attribute Vox.VB_VarHelpID = -1
Private UserName As String
Private DecSep As String
Private Done As Boolean
Private Timeout As Boolean
Private Animate As Boolean
Private Internal As Boolean
Private LastFocus As Integer
Private PrioClass As Long
Private Bits(1 To 9) As Long
Private FirstFree As Long
Private LastFree As Long
Private LastHit As Long
Private PermissionBits As Long
Private Success As Long
Private Const Limit As Long = 999999
Private Const Interval As Long = -1 + 2 ^ 13 'must be of this form: -1 + 2 ^ n
Private AnimDiv As Long
Private i As Long
Private j As Long
Private k As Long
Private Log2 As Double
Private Const Title As String = "Ulli's Sudoku Solver"
Private Function AllAgree(ByVal Cellnumber As Long, ByVal Value As Long) As Boolean
'cross hatching
'returns true if row, column and block agree with Value to be put into Cell(CellNumber)
If Groups(Cells(Cellnumber).RowNumber).Agree(Value) Then
If Groups(Cells(Cellnumber).ColumnNumber).Agree(Value) Then
'check all free cells to find the one with the least possibilities
For j = FirstFree To LastFree
With Cells(j)
If .Value = 0 Then 'free cell
'lower and upper limit for next time
If j < NewFirst Then
NewFirst = j
End If
NewLast = j
If MinPermit Then '... else skip this: MinPermit is already zero - it cannot get any lower
'combined permit pattern
Pattern = Groups(.ColumnNumber).PermitPattern And _
Groups(.RowNumber).PermitPattern And _
Groups(.BlockNumber).PermitPattern
'count the permission bits
CurPermit = 0
If Pattern Then '... else nothing to count
For k = 1 To 9
If Pattern And Bits(k) Then
CurPermit = CurPermit + 1
If CurPermit >= MinPermit Then 'early out; this will not be considered as good anyway
Exit For 'loopávarying k
End If
End If
Next k
End If
'save if less
If CurPermit < MinPermit Then
MinPermit = CurPermit
LastHit = j
PermissionBits = Pattern
End If
End If
End If
End With 'CELLS(j)
Next j
'epilog
FirstFree = NewFirst
LastFree = NewLast
FindLeast = LastHit
Done = (NewLast = -1) 'ie no free cells
End Function
Private Sub Form_Initialize() ':) Line inserted by Formatter
InitCommonControls ':) Line inserted by Formatter
End Sub ':) Line inserted by Formatter
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyEscape
btClear.Value = True
KeyCode = 0
Case vbKeyF3
btExit.Value = True
KeyCode = 0
End Select
End Sub
Private Sub Form_Load()
Dim CmdParam As String
Caption = Title
'get user's name
i = 128
UserName = String$(i, 0)
GetUserName UserName, i
UserName = Left$(UserName, i + (Asc(Mid$(UserName, i, 1)) = 0))
btExit.ToolTipText = "Good Bye, " & UserName
'drop a form shadow
SetClassLong hWnd, GCL_STYLE, GetClassLong(hWnd, GCL_STYLE) Or CS_DROPSHADOW
'prepare for timing measurements
QueryPerformanceFrequency HscFrequ
QueryPerformanceCounter StartTick
QueryPerformanceCounter EndTick
Correction = EndTick - StartTick
'create all textboxes
For i = 1 To 9
For j = 1 To 9
k = k + 1
Load txPuz(k)
With txPuz(k)
.Move j * 33 - 10, i * 33 + 5, 32, 32
.Visible = True
End With 'TXPUZ(K)
Load txSol(k)
With txSol(k)
.Move j * 33 + 405, i * 33 + 5, 32, 32
.Visible = True
End With 'txSol(K)
Next j, i
'instantiate and set up the classes
For i = 0 To 26
Set Groups(i) = New cGroup
Next i
For i = 0 To 80
Set Cells(i) = New cCell
With Cells(i)
.Cellnumber = i
End With 'CELLS(I)
Next i
With MII 'menu iten info
.cbSize = Len(MII)
.fMask = MIIM_STATE
.fState = MFS_DEFAULT
k = GetMenu(hWnd)
For i = 0 To 2
SetMenuItemInfo k, i, True, MII 'set to bold typeface
Next i
End With 'MII
DecSep = Format$(0, "#.")
Log2 = Log(2)
For i = 1 To 9
Bits(i) = 2 ^ i
Next i
mnuAnimSpeed_Click 0
Set Vox = New SpVoice
Select Case True
Case InIDE
If MsgBox("Compiled Code is a lot faster." & vbCrLf & vbCrLf & "Do you want to run me in the IDE anyway?", vbQuestion Or vbYesNo, Title & " [IDE]") = vbNo Then
Unload Me
End If
Case App.PrevInstance
MsgBox Title & " is already loaded.", vbExclamation, "Oops..."
tX - Printontrsion(s"ir = ApeuzDE(TSamixt =. for ek==m+i To 9e .Text = VaTex a(+c1I End v a(+c1I SSSSSoole t = c1I D1I D1I D1I D1I D1I D1I Deuz(SEscaovIBEscaove .TexKtrin
finter Dex)
Coue CeHICH...
ox As TTTTTRefr
a + Hsc
i th
Coue LL InIDE(TSSSSStrin
PrivadPo Animate = .BorderStyle
As Long
bPrinter.Print
As"R
Div 2s BoopNOT J...
et
As"R et
As"R et
End If
n me[ioePe Sub im0 3========/ ApII 'menu .SSol(0).Font-M Ent
Euz(kait As Bi(TSSmnuHidename = vbNullS22'menu .SSol( vbNulWu Puzzle ( Euz
