单击网格就能在网格上填充对应的颜色，单击仿真按钮后就能吧下面的图形在网格相应的位置画出来，用对应网格的颜色画下面的图形。。。。
所要画的图形，
问题：如何吧网格定义成数组a(1 to m,1to n),然后给同一颜色的网格赋值，如黑色网格a（i，j）=1，红色网格a(i,j)=2......，结果是吧图形填充进去
坐等，么么达。。。。

大神们，帮助解释下呗

仿真按钮现在没时间弄。这是基础部分和其他部分

Option Explicit

Const StartX = 0                '格子起始坐标
Const StartY = 0
Const StartH = 600              '格子高
Const StartW = 720              '格子宽
Const m = 12                    '格子横向数
Const n = 12                    '格子纵向数

Dim a(1 To m, 1 To n)
Dim SelIndex As Long

Public Sub view()

'显示函数
Dim i As Long
Dim j As Long
For i = 1 To m
    For j = 1 To n
        If a(i, j) = 0 Then                         '无色
        
            Picture1.Line (StartX + (i - 1) * StartW, StartY + (j - 1) * StartH)-(StartX + i * StartW, StartY + j * StartH), Picture1.BackColor, BF
            Picture1.Line (StartX + (i - 1) * StartW, StartY + (j - 1) * StartH)-(StartX + i * StartW, StartY + j * StartH), , B
        
        ElseIf a(i, j) > 0 And a(i, j) < 5 Then      '对应四色
        
            Picture1.Line (StartX + (i - 1) * StartW, StartY + (j - 1) * StartH)-(StartX + i * StartW, StartY + j * StartH), Label1(a(i, j)).BackColor, BF
            Picture1.Line (StartX + (i - 1) * StartW, StartY + (j - 1) * StartH)-(StartX + i * StartW, StartY + j * StartH), , B
            
        End If
    Next j
Next i

End Sub

Private Sub Form_Load()
Call view
End Sub

Private Sub Label1_Click(Index As Integer)

'选色
If Index > 0 Then
    SelIndex = Index
    Label1(0).BackColor = Label1(SelIndex).BackColor
End If

End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

'单击单元格
Dim i As Long, j As Long

i = Int((X - StartX) / StartW) + 1
j = Int((Y - StartY) / StartH) + 1

If a(i, j) = SelIndex Then
    a(i, j) = 0
Else
    a(i, j) = SelIndex
End If

Call view

End Sub

收到的鲜花

• 胡旭东 于 2015-05-09 11:57 送鲜花  3朵   附言：我很赞同

首先在点击界面左边预设的色块，得到当前色
再用当前色使用line方法画矩形填充。
就是风吹过b版主的方法

你说的仿真稍微不同，需要仿真图形的点阵信息。
再用画点的方法
写了一个画点阵信息的例子，图案是8*8点阵，存在pattern数组中

Option Explicit
Dim pattern(7) As Byte
Private Sub Command1_Click()
Call DrawPattern(100, 70, vbRed)
End Sub
Private Sub Form_Load()
Dim pattern_x As Integer
Dim pattern_y As Integer
Form1.ScaleMode = 3
IniPattern
Form1.AutoRedraw = True
End Sub

Sub IniPattern()
pattern(0) = &H0
pattern(1) = &H78
pattern(2) = &H76
pattern(3) = &H66
pattern(4) = &H26
pattern(5) = &H1C
pattern(6) = &H36
pattern(7) = &H0
End Sub

Sub DrawPattern(x As Integer, y As Integer, c As Long)
Dim temp_x As Integer
Dim temp_y As Integer
Form1.ForeColor = c
For temp_y = 0 To 7
  For temp_x = 0 To 7
    If (pattern(temp_y) And (2 ^ (7 - temp_x))) <> 0 Then Form1.PSet (x + temp_x, y + temp_y)
  Next
Next
End Sub

[ 本帖最后由 lianyicq 于 2015-5-8 10:02 编辑 ]

收到的鲜花

• 胡旭东 于 2015-05-09 11:57 送鲜花  3朵   附言：好文章

Option Explicit

Const StartX = 0                '格子起始坐标
Const StartY = 0
Const StartH = 300              '格子高
Const StartW = 360              '格子宽
Const m = 24                    '格子横向数
Const n = 24                    '格子竖向数

Dim a(1 To m, 1 To n)           '网格数组
Dim SelIndex As Long            '选择的颜色索引，颜色表，放在 lable1 的控件数组中，0号用于显示选中的颜色，1-4为可选的颜色

Dim fz As Long                  '进入仿真的按钮

Public Sub view()

'显示函数
Dim i As Long
Dim j As Long
For i = 1 To m
    For j = 1 To n
        If a(i, j) = 0 Then                         '无色
            '先画色块
            Picture1.Line (StartX + (i - 1) * StartW, StartY + (j - 1) * StartH)-(StartX + i * StartW, StartY + j * StartH), Picture1.BackColor, BF
            '再画网格线
            Picture1.Line (StartX + (i - 1) * StartW, StartY + (j - 1) * StartH)-(StartX + i * StartW, StartY + j * StartH), , B
        
        ElseIf a(i, j) > 0 And a(i, j) < Label1.Count Then       '对应四色
            '先画色块，再画网络线
            Picture1.Line (StartX + (i - 1) * StartW, StartY + (j - 1) * StartH)-(StartX + i * StartW, StartY + j * StartH), Label1(a(i, j)).BackColor, BF
            Picture1.Line (StartX + (i - 1) * StartW, StartY + (j - 1) * StartH)-(StartX + i * StartW, StartY + j * StartH), , B
            
        End If
    Next j
Next i

End Sub

Private Sub Command1_Click()

'进入仿真模式
fz = 1                    '一号图案，如果有多个按钮，可以继续写出 二号图案，三号图案。等等，需要在对应判断中补充图案的坐标

End Sub


Private Sub Label1_Click(Index As Integer)

'选色
If Index > 0 Then               '0号是显示选中色，所以不能被选
    SelIndex = Index            '设置选定几号色
    Label1(0).BackColor = Label1(SelIndex).BackColor            '显示选中色
End If

End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

'单击单元格
Dim i As Long, j As Long

i = Int((x - StartX) / StartW) + 1
j = Int((y - StartY) / StartH) + 1

Select Case fz
    Case 0              '0，无图案，单点
        Call fztc(i, j)                 '直接给色

    Case 1             '一号图案，可以照此扩展出二号图案，三号图案等等
    '仿真，按图案坐标给色，注意，如果原来有这个色，会把这个色给清掉
    Call fztc(i + 1, j)
    Call fztc(i + 2, j)
    Call fztc(i + 3, j)
    
    Call fztc(i, j + 1)
    Call fztc(i + 4, j + 1)
    
    Call fztc(i, j + 2)
    Call fztc(i + 4, j + 2)
    
    Call fztc(i + 1, j + 3)
    Call fztc(i + 2, j + 3)
    Call fztc(i + 3, j + 3)
    
    Call fztc(i + 2, j + 4)
    
    Call fztc(i + 1, j + 5)
    Call fztc(i + 2, j + 5)
    Call fztc(i + 3, j + 5)
    
    Call fztc(i, j + 6)
    Call fztc(i + 4, j + 6)

Case Else                           '图案超范围，忽略掉
    Call fztc(i, j)                 '直接给色

End Select

fz = 0                              '清掉图案状态
Call view                           '绘制

End Sub

Private Sub fztc(x As Long, y As Long)
    
'因为绘制仿真时，需要大量重复判断及赋值，写成过程调用

    If x > m Or y > n Or x < 1 Or y < 1 Then            '超出边界忽略
    Else
        If a(x, y) = SelIndex Then                      '原来是这个色，清掉
            a(x, y) = 0
        Else
            a(x, y) = SelIndex                          '否则给色
        End If
    End If

End Sub

Private Sub Picture1_Paint()
'当画图区域需要刷新时，重绘一下
    Call view                   '加上这句，就不需要把 Picture1的 AutoRedraw 设为真了
End Sub

把仿真部分加进去了，并且加了一个判断，去掉了一个 超范围的判断。增加了一些说明。

发完了，看到 4楼 lianyicq 版主 的的代码，

把
If (pattern(temp_y) And (2 ^ (7 - temp_x))) <> 0 Then Form1.PSet (x + temp_x, y + temp_y)
改成
If (pattern(temp_y) And (2 ^ (7 - temp_x))) <> 0 Then call fztc((x + temp_x, y + temp_y))

就可以使用我的代码，但使用 lianyicq 版主的数据保存方式

感谢哟

Private Sub Form_Load()

 
     Label1(0).BackColor = vbBlack
      Label1(1).BackColor = vbRed
      

 Label1(2).BackColor = vbYellow
  Label1(3).BackColor = vbBlue
   
   Label2.BackColor = QBColor(0)
   DrawState = False                '画图状态标志初始化为False
   Picture1.AutoRedraw = True

a = Val(Form1.Text1.Text)
b = Val(Form1.Text2.Text)
Picture1.Scale (0, 300)-(300, 0)
For i = 0 To a * 20 Step 20
    For j = 0 To b * 20 Step 20
Picture1.Line (i, 0)-(i, j), vbBlack, BF
Picture1.Line (0, j)-(i, j), vbBlack, BF
    Next j
    Next i
    End Sub

Private Sub Label1_Click(Index As Integer)
Label2.BackColor = Label1(Index).BackColor   '在标签2显示颜色
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

 Dim m As Single
Dim n As Single
ReDim a(0 To m, 0 To n)

 Picture1.AutoRedraw = True
If Button = 1 Then
Picture1.AutoRedraw = True
X = X \ 20 + 1
Y = Y \ 20 + 1
X = X * 20
Y = Y * 20
If Label2.BackColor = vbBlack Then
Picture1.Line (X - 20, Y - 20)-(X, Y), vbBlack, BF

ElseIf Label2.BackColor = vbRed Then
Picture1.Line (X - 20, Y - 20)-(X, Y), vbRed, BF

ElseIf Label2.BackColor = vbYellow Then
Picture1.Line (X - 20, Y - 20)-(X, Y), vbYellow, BF

ElseIf Label2.BackColor = vbBlue Then
Picture1.Line (X - 20, Y - 20)-(X, Y), vbBlue, BF

End If
End If




End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim m As Single
Dim n As Single
ReDim a(0 To m, 0 To n)

b = Val(Form1.Text2.Text)
X = X \ 20
Y = Y \ 20
Text1.Text = X & "  ," & Y
m = X
n = Y

End Sub

  这是我自己写的
下面是我自己的小图形的代码，不过不是在一个程序里写的   在两个程序分开写的

Private Sub Picture1_paint()
Dim r As Single
Dim e As Single
Dim h As Single
Dim g As Single
Dim d As Single
Dim f As Single
r = 250
h = 550
d = 2 * r / 3
Picture1.DrawWidth = 13
Picture1.Scale (-1900, 1900)-(1900, -1900)
For e = h / 2 To h / 2 + r Step 1
c = Sqr(r ^ 2 - (e - h / 2) ^ 2)
Picture1.PSet (c, e)
c = -Sqr(r ^ 2 - (e - h / 2) ^ 2)
Picture1.PSet (c, e)
Next e
For g = d / 2 To r Step 1
f = 4 * h * (g - d) ^ 3 / d ^ 3
Picture1.PSet (g, f)
Next g
For j = -r To -(d / 2) Step 1
i = -((4 * h) / (d ^ 3)) * (j + d) ^ 3
Picture1.PSet (j, i)
Next j
For y = -(r + h / 2) To -h / 2 Step 1
X = Sqr(r ^ 2 - (y + h / 2) ^ 2) - (r + d / 2)
Picture1.PSet (X, y)
Next y
For b = -(r + h / 2) To -h / 2 Step 1
a = -Sqr(r ^ 2 - (b + h / 2) ^ 2) + r + d / 2
Picture1.PSet (a, b)
Next b
End Sub

怎么在我的代码基础上加进去呢

学习

在程序的最开始设计这个，来控制绘制的网格的宽和高，
最终的要求就是要模拟成这个样子，只是吧对应网格位置的选中颜色，和对应的图形颜色一样。
大神求助呀，我凌乱了。。。。。

我回复错了 还有看下9楼