急×××解决一个计算机图形学问题!

whupyf 武汉大学 2002-11-26 08:19:52
写一个程序.(废话!)
用鼠标左键绘制多边形的各个定点,右键的功能是闭合曲线。
然后用水平线填充这个多边形。


我知道怎样绘制多边形但是不知道怎样用扫描线填充。
...全文
66 点赞 收藏 24
写回复
24 条回复
切换为时间正序
请发表友善的回复…
发表回复
whupyf 2002-12-02
帮忙的人都有分噢
回复
whupyf 2002-12-01
帮忙讲一下原理,行吗?
回复
James0001 2002-12-01
Option Explicit

Private Type POINTAPI
X As Long
Y As Long
End Type
Private Const HS_HORIZONTAL = 0
Private Const HS_VERTICAL = 1
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function CreateHatchBrush Lib "gdi32" (ByVal nIndex As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Dim pts() As POINTAPI, ptc As Long

Private Sub Form_DblClick()
ptc = 0
Erase pts
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
ReDim Preserve pts(ptc)
With pts(ptc)
.X = ScaleX(X, ScaleMode, vbPixels)
.Y = ScaleY(Y, ScaleMode, vbPixels)
End With
ptc = ptc + 1
ElseIf Button = vbRightButton Then
Dim hBrush As Long, oldBrush As Long
hBrush = CreateHatchBrush(HS_HORIZONTAL, vbBlack)
oldBrush = SelectObject(hdc, hBrush)
Polygon hdc, pts(0), ptc
DeleteObject SelectObject(hdc, oldBrush)
End If
End Sub
回复
thirdapple 2002-11-30
我用了另类解法,你看可以实现就好了,代码太长了,下载地址在:
http://3rdapple.51.net/Fill.zip
--------------------------------------------------------------------
拷贝一段关键的代码:
'实现扫描线填充的算法,只是做个演示
'作者:刘留
'网名:Thirdapple
'E-Mail地址:3rdapple@sohu.com
'个人主页: http://3rdapple.51.net/
'通信地址:四川省遂宁市遂宁中学初2003级三班
'你可以任意传播此代码,但是请不要删除上面的说明文字,如果你对此代码进行了改进,请给我来信,谢谢!

Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
'创建一个多边形区域
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
'创建一个笔刷
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'Windows提供的图象拷贝函数,支持蒙板
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
'填充多边形区域
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'删除创建的对象

Private Type POINTAPI
X As Long
Y As Long
End Type
'一个小类型

Private Const WINDING = 2
'一个参数而已

Dim Polygon() As POINTAPI '多边形区域的各个点的位置记录
Dim DrawState As Boolean '是否开始绘图了
Dim PointCount As Long '多边形有多少个点

Public Function IntFix(Number As Single) As Long '一个方便设置滚动条的小函数而已
IntFix = Number
If IntFix < Number Then IntFix = IntFix + 1
End Function

Function HandFill(X As Single, Y As Single) '填充(代码重点)
Dim HhBrush As Long '笔刷对象
Dim HhRgn As Long '矩形对象
Dim i As Long
PicFrom.Cls '清空PicFrom框
PointCount = PointCount + 1 '在原来的多边形顶点个数的基础上加一
ReDim Preserve Polygon(PointCount) '重新定义多边形区域各个点的位置记录(保留原记录)
Polygon(PointCount).X = X '设置新的顶点X轴位置
Polygon(PointCount).Y = Y '设置新的顶点Y轴位置
DrawState = False '停止绘图了
If PointCount >= 2 And CheckFrame.Value = 1 Then '如果多边形顶点个数大于二而且要显示边框的话
PicFrom.Line (Polygon(1).X, Polygon(1).Y)-(Polygon(PointCount).X, Polygon(PointCount).Y), vbBlack '绘制第一条边框线,万事开头难:)
For i = 2 To PointCount
PicFrom.Line (Polygon(i - 1).X, Polygon(i - 1).Y)-(Polygon(i).X, Polygon(i).Y), vbBlack '分别绘制其他边框线条
Next i
End If
If PointCount >= 3 Then '如果多边形顶点个数大于三的话
HhRgn = CreatePolygonRgn(Polygon(1), PointCount, WINDING) '创建多边形区域
HhBrush = CreateSolidBrush(vbBlack) '创建一个黑色笔刷
FillRgn PicAnd.hdc, HhRgn, HhBrush '填充多边形区域为黑色
PicAnd.Refresh '强制重新显示PicAnd框
DeleteObject HhBrush '删除笔刷对象
BitBlt PicBitBlt.hdc, 0, 0, PicAnd.ScaleWidth, PicAnd.ScaleHeight, PicAnd.hdc, 0, 0, vbSrcPaint '用Or算法拷贝PicAnd中的图象到PicBitBlt中,Or算法不显示黑色
BitBlt PicBitBlt.hdc, 0, 0, PicOr.ScaleWidth, PicOr.ScaleHeight, PicOr.hdc, 0, 0, vbSrcPaint '用Or算法拷贝PicOr中的图象到PicBitBlt中,Or算法不显示黑色
PicBitBlt.Refresh '强制重新显示PicBitBlt框
BitBlt PicFrom.hdc, 0, 0, PicBitBlt.ScaleWidth, PicBitBlt.ScaleHeight, PicBitBlt.hdc, 0, 0, vbSrcAnd '用And算法拷贝PicBitBlt中的图象到PicFrom中显示了,And算法不显示白色
PicFrom.Refresh '强制重新显示PicFrom框
PointCount = 0 '顶点个数归零
ReDim Polygon(PointCount) '当然,也将顶点位置记录归零
End If
End Function

Function HandClick(X As Single, Y As Single) '点击绘制多边形
If PointCount = 0 Then '如果还没有绘制过的话
PicFrom.Cls '清除PicFrom框中画出的东西
DrawState = True '开始绘图了
PicAnd.BackColor = vbBlack '设置PicAnd的背景颜色是黑色
PicOr.BackColor = vbWhite '设置PicOr的背景颜色是白色
PicBitBlt.BackColor = vbBlack '设置PicBitBlt的背景颜色是黑色
For i = 1 To PicAnd.Height Step 2 '开始绘制扫描线
PicAnd.Line (0, i)-(PicAnd.Width, i), vbWhite
PicOr.Line (0, i)-(PicOr.Width, i), vbBlack
Next i
End If
PointCount = PointCount + 1 '顶点个数加一
ReDim Preserve Polygon(PointCount) '重新定义多边形区域各个点的位置记录(保留原记录)
Polygon(PointCount).X = X '设置新的顶点X轴位置
Polygon(PointCount).Y = Y '设置新的顶点Y轴位置
If PointCount >= 2 Then '如果多边形顶点个数大于二
PicFrom.Line (Polygon(PointCount - 1).X, Polygon(PointCount - 1).Y)-(Polygon(PointCount).X, Polygon(PointCount).Y), vbBlack '绘制边框线
End If
End Function

Function HandMove(X As Single, Y As Single) '在鼠标移动时显示实时效果
Dim PointCounts As Long '定义一个临时变量记录多边形顶点个数(因为鼠标移动时下一点位置还没有确定)
Dim i As Long
If DrawState = True Then '如果可以绘图了
PicFrom.Cls '清空PicFrom框
If PointCount > 0 Then '只有多边形顶点个数大于零
PointCounts = PointCount + 1 '临时变量里的多边形顶点个数加一
ReDim Preserve Polygon(PointCounts) '重新定义多边形区域各个点的位置记录(保留原记录)
Polygon(PointCounts).X = X '设置新的顶点X轴位置
Polygon(PointCounts).Y = Y '设置新的顶点Y轴位置
If PointCounts >= 2 Then '如果多边形顶点个数大于二
For i = 2 To PointCounts '依次绘制边框线
PicFrom.Line (Polygon(i - 1).X, Polygon(i - 1).Y)-(Polygon(i).X, Polygon(i).Y), vbBlack
Next i
End If
End If
End If
End Function

'后记:
'做完了,但是或许你还发现不能改变颜色或者改变线条宽度等等,这些我想这么简单,你应该会了,留给你自己去做吧!我还要睡觉,已经0:52 a.m.了
'还是要打上“原创”的记号
'欢迎使用Fantasia Photo(http://3rdapple.51.net/FantasiaPhoto.htm)
'Made by Thirdapple's Studio(http://3rdapple.51.net/)
回复
thirdapple 2002-11-29
Up + 周末写写试试,我想用另外的方法试试
回复
whupyf 2002-11-29
你说对了.
现在我所作的就是使用扫描线填充.
但是,不需要逐个点来填充只需要用水平线代替扫描线.
回复
贴一个相关的,只要改动判断纵坐标就行了
一、引言
区域填充是指先将区域内的一个像素 ,一般称为种子点赋予给定的颜色和辉亮,然后将该颜色扩展到整个区域内的过程。
二、已有的填充算法及缺点
1.扫描线法
扫描线法可以实现已知多边形域边界的填充,多边形域可以是凹的、凸的、还可以是带孔的。该填充方法是按扫描线的顺序,计算扫描线与待填充区域的相交区间,再用要求的颜色显示这些区间的像素,即完成填充工作。这里区间的端点通过计算扫描线与多边形边界线的交点获得。所以待填充区域的边界线必须事先知道,因此它的缺点是无法实现对未知边界的区域填充。
2.边填充算法
边填充的基本思想是:对于每一条扫描线和每条多边形边的交点,将该扫描线上交点右方的所有像素取补。对多边形的每条边作些处理,多边形的顺序随意。该算法适用于具有帧缓冲器的图形系统,按任意顺序处理多边形的边。处理每条边时,仅访问与该边有交的扫描线上交点右方的像素。所有的边都被处理之后,按扫描线顺序读出帧缓冲器的内容,送入显示设备。该算法的优点是简单,缺点是对于复杂图形,每一像素可能被访问多次,重要的是必须事先知道待填充多边形的边界,所以在填充未知边界的区域时不适用。
3.递归算法
递归算法的优点是编程实现时,语言简洁。但在VB6.0实际编程实现时,这种递归算法填充稍稍大一些的图形就会出现堆栈溢出现象,据我们的实践证明,递归算法只能连续递归深度在2090次左右,也就是说,如果待填充的图形大于二千多个像素那么堆栈溢出。下面给出八连通填充方法的VB程序实现(四连通算法同理)。
Public Sub area(p, q As Integer)
If ((imagepixels(0, p, q) = red1) And (imagepixels(1, p, q) = green1) And (imagepixels(2, p, q) = blue1)) Then
imagepixels(0, p, q) = 0: imagepixels(2, p, q) = 0: imagepixels(1, p, q) = 0
Picture1.PSet (p, q), RGB(0, 0, 0)
Call area(p + 1, q): Call area(p, q + 1)
Call area(p - 1, q): Call area(p, q - 1)
Call area(p + 1, q + 1): Call area(p + 1, q - 1)
Call area(p - 1, q + 1): Call area(p - 1, q - 1)
Else: Exit Sub
End If
End Sub
三、算法的基本思想
本算法采用两个队列(FIFO)filled和unfilled来实现区域填充。设计步骤如下:
1. 找出该区域内部任意一点,作为填充种子。
2. 填充该点,并把该点存入队列filled。
3. 按逆时针,判断该点的上、右、下、左邻像素是否在filled队列内。如果在filled,说明该相邻点已填充,若不在filled队列内,则判断该相邻点在未填充队列unfilled,如果不在则将该相邻点存入unfilled。
4. 判断未填充队列是否为空,若不空,则从队列unfilled中取出头元素,转向第三步。若为空则表示已完成所有像素填充,结束程序。
四、程序实现及说明
本算法定义的队列突破了递归算法中受堆栈空间大小的限制的束缚,因为它直接占用内存空间,与堆栈大小无关。以下源程序在Window 2000环境下用VB6.0编程实现。
建立如图所示标准窗体并画上控件-2个CommandButton控件和一个PictureBox控件,调整大小,并设置控件的属性。
4.1 通用声明
Dim Xx As Integer, Yy As Integer
Dim Array1(9000, 2), Array2(9000, 2) As Integer
4.2 采集
Private Sub Command1_Click()
Picture1.MousePointer = 2
End Sub
4.3 选取种子
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Xx = X '选择并记录种子点的位置
Yy = Y
End Sub
4.4 区域填充
Private Sub Command2_Click()
Dim i, j, k As Integer, BoundPoint1, BoundPoint2 As Integer
Dim Flag As Boolean, Pixel As Long
Dim Red, Green, Blue As Integer, Bound As Boolean
Flag = True '初始化
i = Xx: j = Yy: BoundPoint1 = 1
Array1(1, 1) = i
Array1(1, 2) = j
'搜索边界点
Do While BoundPoint1 > 0
BoundPoint2 = 0
For k = 1 To BoundPoint1
i = Array1(k, 1)
j = Array1(k, 2)
'搜索右点
Pixel& = Picture1.Point(i, j + 1)
Call IsBound(Pixel&, Bound)
If Not Bound Then
BoundPoint2 = BoundPoint2 + 1
Array2(BoundPoint2, 1) = i
Array2(BoundPoint2, 2) = j + 1
Picture1.PSet (i, j + 1), RGB(255, 255, 255)
End If
'搜索左邻点
Pixel& = Picture1.Point(i, j - 1)
Call IsBound(Pixel&, Bound)
If Not Bound Then
BoundPoint2 = BoundPoint2 + 1
Array2(BoundPoint2, 1) = i
Array2(BoundPoint2, 2) = j - 1
Picture1.PSet (i, j - 1), RGB(255, 255, 255)
End If
'搜索上邻点
Pixel& = Picture1.Point(i - 1, j)
Call IsBound(Pixel&, Bound)
If Not Bound Then
BoundPoint2 = BoundPoint2 + 1
Array2(BoundPoint2, 1) = i - 1
Array2(BoundPoint2, 2) = j
Picture1.PSet (i - 1, j), RGB(255, 255, 255)
End If
'搜索下邻点
Pixel& = Picture1.Point(i + 1, j)
Call IsBound(Pixel&, Bound)
If Not Bound Then
BoundPoint2 = BoundPoint2 + 1
Array2(BoundPoint2, 1) = i + 1
Array2(BoundPoint2, 2) = j
Picture1.PSet (i + 1, j), RGB(255, 255, 255)
End If
Next k
'数组array2 中的数据传给array1
BoundPoint1 = BoundPoint2
For k = 1 To BoundPoint1
Array1(k, 1) = Array2(k, 1)
Array1(k, 2) = Array2(k, 2)
Next k
Picture1.Refresh
Loop
End Sub
Public Sub IsBound(P As Long, Bound As Boolean) '判断P是否为边界点
Red = P& Mod 256
Bound = False
Green = ((P& And &HFF00) / 256&) Mod 256&
Blue = (P& And &HFF0000) / 65536
If Red = 255 And Green = 255 And Blue = 255 Then
Bound = True
End If
End Sub
五、结束语
本算法实现了在对填充区域的形状、大小均未知的情况下,以种子点开始向四周对该区域进行“扩散式”的填充。本算法解决了传统的递归算法在填充较大区域时(本例中填充区约9800Pixels)堆栈溢出的缺点。我们的实验结果显示,本算法就填充区域大小和运算速度而言,都远远超过了传统的递归算法。
回复
whupyf 2002-11-29
谢谢了!
回复
whupyf 2002-11-28
另外还有个关键解决不了。
就是,如果我的图形是一个复杂的多边形(与一条扫描线有三个以上交点)
甚至,几个复杂多边形相交。我们如何来判断扫描线应该到哪里停止,哪里继续吗?
回复
zyl910 2002-11-26
最近很紧张
没时间写程序

找ThirdApple(第三只苹果)试试
可能他写过
回复
Sean918 2002-11-26
呵呵,你是我们的权威,还是你想办法吧
回复
zyl910 2002-11-26
我说的是严格的计算机图形学问题
回复
whupyf 2002-11-26
对呀!
那该怎么办呢?
回复
Sean918 2002-11-26
我觉得也是坐标的问题,填充可以实现

问题是他是用鼠标画的线,就是说多边形是分多次绘制完成的

用不到Polyline

回复
zyl910 2002-11-26
没你想的那么简单

是 根据参数传来的PointAPI数组绘制出多边形
而不是事先规定好坐标
回复
whupyf 2002-11-26
填满的确是条纹状的。
回复
Sean918 2002-11-26
我随便写了个画不同宽度的水平线的代码,如果能确定多边形范围的话,这样画应该就可以,很简单

Private Sub Form_Load()
Dim i As Integer
Me.AutoRedraw = True
For i = 1 To 8 '''画了8条
DrawWidth = i

Line (800, 200 + 300 * i)-(4000, 200 + 300 * i)
Next
End Sub
回复
zyl910 2002-11-26
扫描线填充的程序没写过


但用API绘制是知道的
用Polyline


Polyline, PolyLineTo

VB声明
Declare Function Polyline Lib "gdi32" Alias "Polyline" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Declare Function PolylineTo Lib "gdi32" Alias "PolylineTo" (ByVal hdc As Long, lppt As POINTAPI, ByVal cCount As Long) As Long
说明
用当前画笔描绘一系列线段。使用PolylineTo函数时,当前位置会设为最后一条线段的终点。它不会由Polyline函数改动
返回值
Long,非零表示成功,零表示失败
参数表
参数 类型及说明
hdc Long,要在其中绘图的设备场景
lpPoint POINTAPI,nCount POINTAPI结构数组中的第一个POINTAPI结构
nCount Long,lpPoint数组中的点数。会从第一个点到第二个点画一条线,以次类推




'Spiral
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function PolylineTo Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, ByVal cCount As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpPoint As Any) As Long
Private Sub Form_Load()
'KPD-Team 1998
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
Me.ScaleMode = vbPixels
End Sub
Private Sub Form_Paint()
Dim Pt(1 To 1000) As POINTAPI, Angle As Single, Radius As Single
Dim Number As Integer, XMid As Long, YMid As Long
XMid = Me.ScaleWidth / 2
YMid = Me.ScaleHeight / 2
'Fill our array with points
For Number = 1 To 1000
Angle = Number * 0.1
Radius = Radius + Angle * 0.01
Pt(Number).x = XMid + Cos(Angle) * Radius
Pt(Number).y = YMid - Sin(Angle) * Radius
Next Number
'Set the co?rdinates of the active point
MoveToEx Me.hdc, Me.ScaleWidth / 2, Me.ScaleHeight / 2, ByVal 0&
'Draw several lines
PolylineTo Me.hdc, Pt(1), 1000
End Sub
Private Sub Form_Resize()
Me.Cls
Form_Paint
End Sub
回复
Sean918 2002-11-26
我想问一下,你右键是怎么闭合曲线的?就是把最后的两个点连线是不是?

水平线填充这个多边形,怎么填充?全部填满还是条纹状的?
回复
whupyf 2002-11-26
不能用填充函数,否则就不叫计算机图形学了
回复
发动态
发帖子
VB基础类
创建于2007-09-28

7451

社区成员

VB 基础类
申请成为版主
社区公告
暂无公告