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

Question

polygon 函数polypolygon 函数

Answer 1

zyl910  ， API 版主你去发消息给他好了

Answer 2

扫描线填充的程序没写过
但用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: [email protected]
    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

Answer 3

我随便写了个画不同宽度的水平线的代码，如果能确定多边形范围的话，这样画应该就可以，很简单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

Answer 4

没你想的那么简单是 根据参数传来的PointAPI数组绘制出多边形
而不是事先规定好坐标

Answer 5

我觉得也是坐标的问题，填充可以实现问题是他是用鼠标画的线，就是说多边形是分多次绘制完成的用不到Polyline

Answer 6

最近很紧张
没时间写程序找ThirdApple(第三只苹果)试试
可能他写过

Answer 7

贴一个相关的，只要改动判断纵坐标就行了
一、引言 
区域填充是指先将区域内的一个像素 ，一般称为种子点赋予给定的颜色和辉亮，然后将该颜色扩展到整个区域内的过程。  
二、已有的填充算法及缺点 
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）堆栈溢出的缺点。我们的实验结果显示，本算法就填充区域大小和运算速度而言，都远远超过了传统的递归算法。

Answer 8

我用了另类解法，你看可以实现就好了，代码太长了，下载地址在：
http://3rdapple.51.net/Fill.zip
--------------------------------------------------------------------
拷贝一段关键的代码：
'实现扫描线填充的算法，只是做个演示
'作者：刘留
'网名：Thirdapple
'E-Mail地址：[email protected]
'个人主页： 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 FunctionFunction 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 FunctionFunction 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 FunctionFunction 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/)

Answer 9

Option ExplicitPrivate 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 LongDim pts() As POINTAPI, ptc As LongPrivate Sub Form_DblClick()
  ptc = 0
  Erase pts
End SubPrivate 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