萌妹子被这个问题难住了，求大神们解决，，，好人一身平安 - 编程论坛

#2

胡旭东2015-05-07 21:36

大神们，帮助解释下呗

#3

风吹过b2015-05-08 08:35

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

程序代码：

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

#4

lianyicq2015-05-08 09:27

回复楼主胡旭东

首先在点击界面左边预设的色块，得到当前色
再用当前色使用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 编辑 ]

#5

风吹过b2015-05-08 10:05

程序代码：

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

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

#6

风吹过b2015-05-08 10:08

发完了，看到 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 版主的数据保存方式

#7

胡旭东2015-05-09 11:44

回复 5楼风吹过b

感谢哟

程序代码：

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

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

#8

tlliqi2015-05-09 11:49

学习

#9

胡旭东2015-05-09 11:52

回复 7楼胡旭东

只有本站会员才能查看附件，请登录

在程序的最开始设计这个，来控制绘制的网格的宽和高，

只有本站会员才能查看附件，请登录

最终的要求就是要模拟成这个样子，只是吧对应网格位置的选中颜色，和对应的图形颜色一样。
大神求助呀，我凌乱了。。。。。

#10

胡旭东2015-05-09 11:59

回复 6楼风吹过b

我回复错了还有看下9楼

#11

renxiaoyao362015-05-09 13:04

回复 9楼胡旭东

天哪，你这个图案是要让我们绘制一个JPG图片么？
看样子要求很精细，这个分辨率太高了，代码会很大的，不大可能有作业要这样的，你是不是发错了？

#12

风吹过b2015-05-09 21:04

9楼的图案，我做不出。我想了半天，只想到一个办法。
你去认真研究 3D引擎吧，然后使用 3D引擎绘制这个，然后引擎会帮你处理那部分前，那部分在后的透视问题。

现在虚幻4的引擎免费了，你真的可以去认真研究了。

VB6可以调用 DX 来做这些，但我不会。

#13

wmf20142015-05-09 22:11

我觉得9楼图像可以用正弦图像模拟，层叠关系也是固定的，这个思路不知道能不能作为参考。

#14

风吹过b2015-05-09 23:05

层叠关系是固定，但我们一般情况下生成图形时，不会处理透视情况。

我感觉：
它这个，应该是在空间上排布，然后映射成一个图片。
同一个部件，有在前面的，也有在后面的。需要用于 3D 处理里的透视情况。

#15

renxiaoyao362015-05-10 07:47

综上所述，还是建议用3D引擎，3D引擎只要你给一些参数，它会自己生成的，有现成的不用才是傻瓜，风版主告诉你了用什么引擎，自己去试试吧

#16

xuezeyu2015-05-10 14:52

什么鬼

#17

lianyicq2015-05-11 11:38

回复 9楼胡旭东

如果按9楼图案，只换颜色不作尺寸放缩，能够实现。
如果要放缩，有可能实现，正在试，要花点时间。
...
用比例缩放的笨办法做出效果是这样，如果填充单色可以实现，渐变比较麻烦
[attach]80199[/attach]
单色填充效果如下：

只有本站会员才能查看附件，请登录

代码不复杂，只是比较琐碎，就不贴了，如果需要，可以给你思路自己按思路做。

[ 本帖最后由 lianyicq 于 2015-5-12 11:03 编辑 ]