【求助】用VB怎么实现随机关联控件 - VB6论坛

得分:20

回复楼主 baiduqusi

首先，你格子数不一定能被3整除，所以有一个空白格子的问题。
其次，点（1.1）时关联的两个格子变成背景色，再点（1.2）时（2.1）也变成背景色，（2.2）已经是背景色就变回前景色
这句语我的理解是点击格子的本身不变色，它关联的两个格子变色。不知对不对
第三，你这个程序的要求没说清楚，是不是显示格子就可以，还是必须使用控件。

下面的代码是使用显示格子的。

-------------------------
窗体：
在窗体上放一个 Picture1 ，大小为一个正方形便可，大一些更好。
我写程序时的大小是 4815 * 4815 缇，放 5*5 的格子时，DEBUG 正好。
工程就不上传了。因为只用一个控件。

程序代码：

Option Explicit
Dim N As Long            '格子的大小

Dim GD As Long           '每个格子的大小（画图）
Dim BJ As Long           '边距

Private Type 坐标
    z As Long           '值，未使用
    X As Long           '坐标
    Y As Long
    L1 As Long          '关联的元素的下标
    L2 As Long
    zt As Boolean           '当前状态
End Type

Const ColorQ = &H8000000F           '前景色,系统前景色，一般为白
Const colorB = &HFFFF00             '背景色, BGR 顺序

Dim G() As 坐标         '每个格子的数据

Private Sub Form_Load()

Randomize               '初始化随机数发生器

Dim s As String

Do                      '使用死循环要求输入格子数量
s = InputBox("请输入一个2以上，10以内的，以便生成网络", "初始大小")

If IsNumeric(s) Then            '如果输入的是数值
    N = Int(Val(s))             '取值，并取整
    If N < 2 Or N > 10 Then N = 0       '是否在范围内
Else
    N = 0
End If
Loop While N = 0                '不符合要求重新循环

ReDim G(N * N)                  '初始化元素

Picture1.AutoRedraw =True 
Call 画框                       '画框

Call 关联                       '产生关联

End Sub

Private Sub 关联()
Dim J1 As Long

J1 = Int(N * N / 3)         '按3倍数计算有多少组关联，剩余部分（1个或2个）不管

Dim i As Long
Dim j As Long

For i = 1 To J1
    'j = NEXTG               '先产生一个没有关联的
    j = NEXTRNDG               '先产生一个没有关联的
    '------这两种产生新一组关联的方式在最终结果上有区别--------
    '第一种会让剩余的空白元素在最后几格内的几率更大
    '第二种会让剩余的空白元素在前面一些的几率更大，看实际使用哪一种
    '如果需要让剩余的空白元素随机出现在任意格，那么需要先把空白元素标识出来再去生成关联
        
    G(j).L1 = NEXTRNDG(j)       '先产生一个随机 第一元素 ，并关联上
    G(G(j).L1).L1 = j       '反关联 也关联上
    
    G(j).L2 = NEXTRNDG(j)   '产生第二个关联
    G(G(j).L1).L2 = G(j).L2     '把第一个关联的元素也关联到第二个元素上
    
    G(G(j).L2).L1 = j           '针对第二个元素，关联到初始元素和第一元素上
    G(G(j).L2).L2 = G(j).L1
Next i

End Sub


Private Sub 画框()

'每边留 150 缇 ，计算每个格子的大小
'再按格子大小修正为 像素
GD = (Picture1.ScaleHeight - 300) / N
GD = Int(GD / Screen.TwipsPerPixelX) * Screen.TwipsPerPixelX

'再根据格子大小修正每边的距离
BJ = (Picture1.ScaleHeight - GD * N) / 2

Dim i As Long

Dim X As Long, Y As Long

For i = 1 To N * N
'计算坐标
    If i Mod N = 0 Then           '每行的最后一格，需要特殊处理
        G(i).X = BJ + (N - 1) * GD
        G(i).Y = BJ + Int(i / N - 1) * GD
    Else                          '其余的不需要特殊处理
        G(i).X = BJ + (i Mod N - 1) * GD
        G(i).Y = BJ + Int(i / N) * GD
    End If
    '画一个空格，分两步画，第一次是用背景画填充的方块，第二次再画格子线
    Picture1.Line (G(i).X, G(i).Y)-(G(i).X + GD, G(i).Y + GD), ColorQ, BF
    Picture1.Line (G(i).X, G(i).Y)-(G(i).X + GD, G(i).Y + GD), , B
Next i

End Sub

Public Function NEXTG()     '返回下一个没有关联的元素
Dim i As Long
For i = 1 To N * N                      '从第一个元素找起，找到没有任何关联的元素。
    If G(i).L1 = 0 Or G(i).L2 = 0 Then
        Exit For
    End If
Next i
NEXTG = i
End Function

Public Function NEXTRNDG(Optional cs As Long = 0)         '随机返回一个没有关联的元素
Dim i As Long

Do                          '与上一个函数相比，顺序号是随机而以，都是找一个没有任何关联的元素
i = Int(Rnd() * N * N + 1)
If G(i).L1 = 0 And G(i).L2 = 0 Then
    If cs > 0 Then
        If i <> cs Then Exit Do
    Else
        Exit Do
    End If
End If
Loop

NEXTRNDG = i

End Function


Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'按下鼠标，不分左右键

Dim x1 As Long, y1 As Long
Dim i As Long
x1 = Int((X - BJ) / GD)             '换算成格子的2维坐标
y1 = Int((Y - BJ) / GD)
i = y1 * N + x1 + 1                 '换算元素的下标

If i <= N * N And i > 0 Then               '如果换算的下标在范围内
    If G(i).L1 > 0 Then             '置状态
        'G(i).zt = Not G(i).zt      '本身变色
        G(G(i).L1).zt = Not G(G(i).L1).zt   '关联的格子变色
        G(G(i).L2).zt = Not G(G(i).L2).zt
        Call 画单个块(i)
        Call 画单个块(G(i).L1)
        Call 画单个块(G(i).L2)
    End If
End If

'Call debugprint                     'DEBUG，显示每个元素的属性

End Sub

Private Sub 画单个块(cs As Long)
    
    If G(cs).zt Then
        Picture1.Line (G(cs).X, G(cs).Y)-(G(cs).X + GD, G(cs).Y + GD), colorB, BF
    Else
        Picture1.Line (G(cs).X, G(cs).Y)-(G(cs).X + GD, G(cs).Y + GD), ColorQ, BF
    End If
    '画格子线
    Picture1.Line (G(cs).X, G(cs).Y)-(G(cs).X + GD, G(cs).Y + GD), , B
End Sub

Private Sub debugprint()
'DEBUG ，显示每个元素的属性
Dim i As Long
Dim j As Long

For i = 1 To N * N
    j = 1
    debugprintsub i, 1, "index:", i
    
    j = j + 1
    debugprintsub i, j, "X:", G(i).X
    
    j = j + 1
    debugprintsub i, j, "Y:", G(i).Y
    
    j = j + 1
    debugprintsub i, j, "L1:", G(i).L1
    
    j = j + 1
    debugprintsub i, j, "L2:", G(i).L2

    j = j + 1
    debugprintsub i, j, "ZT:", G(i).zt

Next i

End Sub

Private Sub debugprintsub(index As Long, js As Long, caption As String, value As Variant)
    
    Picture1.CurrentX = G(index).X + 30                     '定位
    Picture1.CurrentY = G(index).Y + 30 + 135 * (js - 1)
    Picture1.Print caption; value                           '显示内容

End Sub

[ 本帖最后由风吹过b 于 2014-3-9 21:20 编辑 ]

授人于鱼，不如授人于渔
早已停用QQ了