Тема: « Массивы»

Option Explicit
Const r = 90, rr = 900, nn = 10
Dim WithEvents pb As PictureBox, im As Image
Dim WithEvents cb As CommandButton
Dim i&, v, a$(), s$, ss As String * nn, ll&(1 To nn)
 
Private Sub cb_Click()
    Dim i&, j&, ii&, l&
    Debug.Print Mid$(cb.Name, 3)
    Select Case Mid$(cb.Name, 3)
    Case 1: Call reset
    Case 2
        'Решение
        Do
            ii = InStr(ii + 1, ss, 1)
            s = ""
            If ii > 0 Then
                l = ll(ii)
                For i = 1 To 6: For j = 1 To 6
                    If l + i + j = nn Then
                        s = s & " " & i & "," & j
                    End If
                Next: Next
'                a = Split(s)
'                a = Split(a(Rnd * (UBound(a) + 1)), ",")
                Stop
            End If
            
        Loop While ii > 0
    
    End Select
End Sub
 
Private Sub reset()
    ss = ""
    Erase ll
    For i = 1 To nn: Controls("im" & i).Visible = 0: Next
    Controls("cb2").Enabled = 0
End Sub
 
Sub SetNum(ByVal Index&, ByVal Num&)
    Randomize Timer
    If Index < 1 Or Index > nn Then Exit Sub
    If Num < 0 Or Num > 6 Then Exit Sub
    With Controls("cb2")
        If .Enabled Then Exit Sub
        With Controls("im" & Index)
            If Index <= 5 And InStr(1, Left$(ss, nn \ 2), 1) > 0 Then
                MsgBox "В левой части уже есть кубик", vbExclamation: Exit Sub
            ElseIf Index > 5 And InStr(1, Mid$(ss, nn \ 2 + 1), 1) > 0 Then
                MsgBox "В правой части уже есть кубик", vbExclamation: Exit Sub
            End If
            .Visible = Num > 0
            .Move -(6 - Num) * rr
            Mid$(ss, Index, 1) = 1
            ll(Index) = Num
        End With
        .Enabled = Replace$(ss, " ", "") = 11
    End With
End Sub
 
Private Sub Form_Activate()
    pb.SetFocus
End Sub
 
Private Sub Form_Load()
    Dim l&, t&, w&, h&
    
    l = r: t = r: w = rr: h = rr
    For i = 1 To nn
        Set pb = Controls.Add("vb.PictureBox", "pb" & i): With pb
            .Move l, t, w, h: l = l + w
            .Visible = 1
            Set im = Controls.Add("vb.Image", "im" & i, pb): With im
                Set .Picture = Me.Picture
            End With
        End With
    Next
    Set Me.Picture = Nothing
    l = r: t = t + rr + r: i = 0
    For Each v In Array("Сброс", "Найти решение"): i = i + 1
        Set cb = Controls.Add("vb.CommandButton", "cb" & i): With cb
            .Move l, t, rr * 2, rr \ 2: l = l + .Width + r
            .Caption = v
            .Visible = 1
        End With
    Next
    reset
    Me.Caption = "Кости-10"
End Sub
 
Private Sub pb_Click()
    SetNum Mid$(pb.Name, 3), Fix(Rnd * 6 + 1)
End Sub
 
Private Sub cb_LostFocus()
    pb_LostFocus
End Sub
 
Private Sub pb_LostFocus()
    If TypeOf ActiveControl Is PictureBox Then Set pb = ActiveControl
    If TypeOf ActiveControl Is CommandButton Then Set cb = ActiveControl
End Sub

Private Sub Text1_Change(Index As Integer)
'для ручного подбора
On Error Resume Next
col = vbGreen
For i = 0 To 7
    Sum = 0
    Sum = CInt(Text1(i)) + CInt(Text1(i + 1)) + CInt(Text1(i + 2))
    If Not Sum = 10 Then col = vbWhite
Next
For i = 0 To 9
    Text1(i).BackColor = col
Next
End Sub
 
Private Sub Command1_Click()
'случайный выбор 2 заданых кубиков
For i = 0 To 9
    Text1(i) = 0
Next
t1 = Int(Rnd() * 10)
Text1(t1) = Int(Rnd() * 6 + 1)
Do
    t2 = Int(Rnd() * 10)
Loop While t2 = t1
Do
    Text1(t2) = Int(Rnd() * 6 + 1)
Loop While CInt(Text1(t1)) + CInt(Text1(t2)) > 9
End Sub
 
Private Sub Command2_Click()
Dim x&(2)
x(0) = 0: x(1) = 0: x(2) = 0
For i = 0 To 9
    If Not IsNumeric(Text1(i)) Then Exit Sub
    If CInt(Text1(i)) > 0 Then
        k = i Mod 3
        If Not x(k) = 0 Then
            If CInt(Text1(i)) = x(k) Then
                'если есть только 1 значение
                For j = 0 To 2
                    If Not j = k Then
                    x(j) = 1
                    GoTo out
                    End If
                Next
            Else
                MsgBox "нет решений"
                Exit Sub
            End If
        End If
        x(k) = CInt(Text1(i))
    End If
Next
 
If x(0) + x(1) + x(2) > 9 Then MsgBox "нет решений": Exit Sub
out:
If x(0) = 0 Then x(0) = 10 - x(1) - x(2)
If x(1) = 0 Then x(1) = 10 - x(0) - x(2)
If x(2) = 0 Then x(2) = 10 - x(1) - x(0)
 
For i = 0 To 9
    k = i Mod 3
    Text1(i) = x(k)
Next
End Sub

        Do
            ii = InStr(ii + 1, ss, 1)
            s = ""
            If ii > 0 Then
                l = ll(ii): n = n + 1
                For i = 1 To 6: For j = 1 To 6
                    If l + i + j = nn Then
                        s = s & " " & i & "," & j
                    End If
                Next: Next
                a = Split(Mid$(s, 2))
                a = Split(a(Fix(Rnd * (UBound(a) + 1))), ",")
                If ii = Choose(n, 1, 6) Then
                    s = Choose(n, 2, 7) & "," & Choose(n, 3, 8)
                ElseIf ii = Choose(n, 5, 10) Then
                    s = Choose(n, 3, 8) & "," & Choose(n, 4, 9)
                Else:
                    s = ii - 1 & "," & ii + 1
                End If: i = 0
                
                For Each v In Split(s, ",")
                    With Controls("im" & v)
                        .Move -(6 - a(i)) * rr
                        .Visible = 1
                    End With
                    i = i + 1
                Next
                
            End If
            
        Loop While ii > 0