非典型扫描线填充正方形的4-连通边界填充算法

Option   Explicit

Private  cltStackX  As  Collection
Private  lTopX  As   Long
Private  cltStackY  As  Collection
Private  lTopY  As   Long

Dim  X%, Y%
Const  Vnumber  =   7        ' 一共7个点
Const  xMax  =   14       ' 坐标最大值12
Const  grid  =   400

Private   Sub Command1_Click() Sub Command1_Click()
Form1.Cls
Call DrawCoordinate
Call DrawPset
If Text1.Text <> "" And Text2.Text <> "" Then
    Call Fill(Text1.Text, Text2.Text)
End If
End Sub

Private   Sub Form_Load() Sub Form_Load()
    Dim x0, y0, x1, y1 As Single
    x0 = -ScaleWidth / 4
    y0 = ScaleHeight - 200
    x1 = ScaleWidth * 3 / 4 - 200
    y1 = -200
    Scale (x0 + 1500, y0)-(x1 + 1500, y1)
    Call Class_InitializeX
    Call Class_InitializeY
End Sub

Private   Sub Form_Activate() Sub Form_Activate()
Dim X, Y As Integer
X = 0
Y = 0
Call DrawCoordinate     '调用画格子过程
Call DrawPset
End Sub

Private   Sub DrawCoordinate() Sub DrawCoordinate()        '画坐标方格
Dim i As Integer
For i = 1 To xMax + 1
    Line (0, Y)-(xMax * grid, Y)
    Line (X, 0)-(X, xMax * grid)
    X = X + grid
    Y = Y + grid
Next
End Sub

Private   Sub DrawPset() Sub DrawPset()
Dim i As Integer
    DrawWidth = 15 '划笔粗细
    For i = 2 To 12
            PSet (i * grid, 2 * grid), vbBlue
    Next i
    For i = 2 To 12
            PSet (2 * grid, i * grid), vbBlue
    Next i
    For i = 2 To 12
            PSet (12 * grid, i * grid), vbBlue
    Next i
    For i = 2 To 12
            PSet (i * grid, 12 * grid), vbBlue
    Next i
    DrawWidth = 1: X = 0: Y = 0
End Sub

Private   Sub Class_InitializeX() Sub Class_InitializeX()
    Set cltStackX = New Collection
    lTopX = 0
End Sub

Public   Sub PushX() Sub PushX(data As Integer)
    cltStackX.Add data, CStr(lTopX)
    lTopX = lTopX + 1
End Sub

Public   Function PopX() Function PopX() As Integer
    PopX = cltStackX.Item(lTopX)
    cltStackX.Remove (lTopX)
    lTopX = lTopX - 1
End Function

Public   Function IsEmptyX() Function IsEmptyX() As Boolean
    IsEmptyX = (lTopX <= 0)
End Function

Private   Sub Class_InitializeY() Sub Class_InitializeY()
    Set cltStackY = New Collection
    lTopY = 0
End Sub

Public   Sub PushY() Sub PushY(data As Integer)
    cltStackY.Add data, CStr(lTopY)
    lTopY = lTopY + 1
End Sub

Public   Function PopY() Function PopY() As Integer
    PopY = cltStackY.Item(lTopY)
    cltStackY.Remove (lTopY)
    lTopY = lTopY - 1
End Function

Public   Function IsEmptyY() Function IsEmptyY() As Boolean
    IsEmptyY = (lTopY <= 0)
End Function

Private   Sub Fill() Sub Fill(ptX As Integer, ptY As Integer)
    Dim Sign As Boolean
    Dim xRight, xLeft As Integer
    Dim xT, yT As Integer
    Dim i As Integer
    Dim counter As Double
    DrawWidth = 15 '划笔粗细
    If ptX > 2 And ptX < 12 And ptY > 2 And ptY < 12 Then
        Sign = True
    End If
    If Sign = True Then
        PushX (ptX)
        PushY (ptY)
        Do While IsEmptyX = False
            '处理种子所在线
            xT = PopX
            yT = PopY
            
            i = xT
            Do
                For counter = 1 To 1000000
                Next
                If Point(i * grid, yT * grid) = vbBlue Then
                    Exit Do
                End If
                PSet (i * grid, yT * grid), vbRed       '填充点
                i = i + 1
            Loop
            
            i = xT
            Do
                For counter = 1 To 1000000
                Next
                If Point(i * grid, yT * grid) = vbBlue Then
                    Exit Do
                End If
                PSet (i * grid, yT * grid), vbRed       '填充点
                i = i - 1
            Loop
            '处理下一条线
            i = xT
            If Point(i * grid, (yT - 1) * grid) <> vbBlue And Point(i * grid, (yT - 1) * grid) <> vbRed Then
                Do
                    If Point(i * grid, (yT - 1) * grid) = vbBlue Then
                        xLeft = i + 1
                        PushX (xLeft)
                        PushY (yT - 1)
                        Exit Do
                    End If
                    i = i - 1
                Loop
            End If
            '处理上一条线
            i = xT
            If Point(i * grid, (yT + 1) * grid) <> vbBlue And Point(i * grid, (yT + 1) * grid) <> vbRed Then
                Do
                    If Point(i * grid, (yT + 1) * grid) = vbBlue Then
                        xLeft = i + 1
                        PushX (xLeft)
                        PushY (yT + 1)
                        Exit Do
                    End If
                    i = i - 1
                Loop
            End If
        Loop
    Else
        MsgBox ("所用种子点超出正方形范围...")
    End If
    DrawWidth = 1: X = 0: Y = 0
End Sub

新人写的一个非典型扫描线填充正方形的4-连通边界填充算法...用到了栈的结构...VB6.0

如果有幸被高人看见...希望指正...