测试vb1.bas

应用编码与计算机密码学>程序 如果好的话请发言

      PO1.x = temp
      temp = PO2.y
      PO2.y = PO1.y
      PO1.y = temp
   End If
   
   If PO1.x < PO2.x And PO1.y > PO2.y Then
      temp = PO2.x
      PO2.x = PO1.x
      PO1.x = temp
   End If
   
   If PO1.x > PO2.x And PO1.y < PO2.y Then
      temp = PO1.y
      PO1.y = PO2.y
      PO2.y = temp
   End If
   
   If PO1.x > PO2.y And PO1.y > PO2.y Then
    mpo1.x = PO1.x - 1
    mpo2.x = PO2.x
    mpo1.y = PO2.y + 1
    mpo2.y = PO2.y + 1
    End If
    If mpo1.x = mpo2.x And mpo1.x <> 0 Then Exit Sub
    If HasColor = 1 Then
        'If PC.BackColor <> color_in Then
        For Index = 1 To Abs(PO1.y - PO2.y - 1)
           myline pc, mpo1, mpo2, 1, 1, color_in
           mpo1.y = mpo1.y + 1
           mpo2.y = mpo1.y
        Next
       ' End If
    End If

    
   temp = PO1.x
   PO1.x = PO2.x
   myline pc, PO1, PO2, 1, 1, color_out
   PO1.x = temp
   temp = PO2.x
   PO2.x = PO1.x
   myline pc, PO1, PO2, 1, 1, color_out
   PO2.x = temp
   temp = PO2.y
   PO2.y = PO1.y
   myline pc, PO1, PO2, 1, 1, color_out
   PO2.y = temp
   PO1.y = PO2.y
   myline pc, PO1, PO2, 1, 1, color_out
   PO1.x = a1
   PO1.y = a2
   PO2.x = a3
   PO2.y = a4
End Sub

Public Sub myPolygon(pc As PictureBox, POcnt As Integer, PO() As Point, color_in, color_out, Optional HasColor = 1)
   Dim i As Integer
   Dim A As Point
   Dim Xmax, Xmin, Ymax, Ymin
   Dim x, y As Integer
   
   For i = 1 To POcnt - 1
     myline pc, PO(i), PO(i + 1), 1, 1, color_out
   Next i
   myline pc, PO(POcnt), PO(1), 1, 1, color_out
   If pc.BackColor = color_in Then Exit Sub
   x = 0
   y = 0
   For i = 1 To POcnt
     x = x + PO(i).x
     y = y + PO(i).y
   Next i
   A.x = x / POcnt
   A.y = y / POcnt
   If HasColor = 1 Then
      setColor pc, A, color_in
   End If
   Exit Sub
   
'   Randomize Timer
'   For i = 1 To 1000
'       'a.X = PC.width * Rnd
'       'a.Y = PC.Height * (1 - Rnd)
'       a.X = Xmin + Int(Rnd * (Xmax - Xmin) + 1)
'       a.Y = Ymin + Int(Rnd * (Ymax - Ymin) + 1)
'       If Inside(a, POcnt, po) = True Then
'          setColor PC, a, color_in
'          Exit Sub
'       End If
'   Next i
 '  MsgBox "Random lost"
End Sub

Public Sub myCircle(pc As PictureBox, PO As Point, R, color_in, color_out, Optional HasColor = 1)
On Error GoTo handle
   
   Dim i1 As Boolean
   Dim PO1 As Point
   Dim PO2 As Point
   Dim PO3 As Point
   Dim PO4 As Point
   Dim r2 As Long
   Dim f As Currency
   Dim flag As Boolean
   
   i1 = False
   flag = False
   
   PO1.x = PO.x + R
   PO1.y = PO.y
   r2 = R * R
   f = 0
   
   PO2.x = PO1.x
   PO2.y = PO1.y
   While (i1 = False)
       PO1.x = 2 * PO.x - PO2.x
       PO1.y = 2 * PO.y - PO2.y
       PO3.x = PO1.x
       PO3.y = PO2.y
       PO4.x = PO2.x
       PO4.y = PO1.y
       
       'If color_in <> PC.BackColor And flag <> True And HasColor = 1 Then
       If flag <> True And HasColor = 1 Then
            myline pc, PO2, PO4, 1, 1, color_in
            myline pc, PO1, PO3, 1, 1, color_in
       End If
       
       pc.PSet (PO1.x, PO1.y), color_out
       pc.PSet (PO2.x, PO2.y), color_out
       pc.PSet (PO3.x, PO3.y), color_out
       pc.PSet (PO4.x, PO4.y), color_out
       If f > 0 Then
          PO2.x = PO2.x - 1
          f = (PO2.x - PO.x) * (PO2.x - PO.x) + (PO2.y - PO.y) * (PO2.y - PO.y) - r2
       '   f = ((PO2.X - PO.X)  * ((PO2.X - PO.X)  + ((PO2.Y - PO.Y)  * (PO2.Y - PO.Y) - 1
          flag = False
       Else
          flag = True
          PO2.y = PO2.y + 1
          f = (PO2.x - PO.x)
          f = f * (PO2.x - PO.x)
          f = f + (PO2.y - PO.y) * (PO2.y - PO.y)
          f = f - r2
       End If
       If PO2.x < PO.x Then i1 = True
   Wend
Exit Sub

handle:
 
   
End Sub

Public Sub myBline(pc As PictureBox, PO() As Point, width, color)
   Dim PO1 As Point
   Dim PO2 As Point
   Dim t As Double
   Dim mstep As Double
   Dim fen As Integer
   Dim i As Integer
   If PO(1).x <> PO(3).x Then
    
    fen = Abs(PO(1).x - PO(3).x)
    mstep = 1 / fen


    For i = 1 To width
        PO1.x = PO(1).x
        PO1.y = PO(1).y
        PO(1).y = PO(1).y + i - 1
        PO(2).y = PO(2).y + i - 1
        PO(3).y = PO(3).y + i - 1
        For t = mstep To 1 Step mstep
           'change place 2,3 by hpk
           PO2.x = (1 - t) * (1 - t) * PO(1).x + 2 * t * (1 - t) * PO(3).x + t * t * PO(2).x
           PO2.y = (1 - t) * (1 - t) * PO(1).y + 2 * t * (1 - t) * PO(3).y + t * t * PO(2).y
           myline pc, PO1, PO2, 1, 1, color
           PO1.x = PO2.x
           PO1.y = PO2.y
        Next t
    Next i
   End If
End Sub

Public Sub myEllispce(pc As PictureBox, PO As Point, A, B, color_in, color_out, Optional HasColor = 1)
   Dim i1 As Boolean
   Dim PO1 As Point
   Dim PO2 As Point
   Dim PO3 As Point
   Dim PO4 As Point
   Dim r2 As Long
   Dim f As Double
   Dim flag As Boolean
   
   If A = 0 Or B = 0 Then Exit Sub
   
   i1 = False
   flag = False
   
   PO1.x = PO.x + A
   PO1.y = PO.y
   f = 0
   
   PO2.x = PO1.x
   PO2.y = PO1.y
   While (i1 = False)
       PO1.x = 2 * PO.x - PO2.x
       PO1.y = 2 * PO.y - PO2.y
       PO3.x = PO1.x
       PO3.y = PO2.y
       PO4.x = PO2.x
       PO4.y = PO1.y
       'If color_in <> PC.BackColor And flag <> True And HasColor = 1 Then
       If flag <> True And HasColor = 1 Then
            myline pc, PO2, PO4, 1, 1, color_in
            myline pc, PO1, PO3, 1, 1, color_in
       End If
       pc.PSet (PO1.x, PO1.y), color_out
       pc.PSet (PO2.x, PO2.y), color_out
       pc.PSet (PO3.x, PO3.y), color_out
       pc.PSet (PO4.x, PO4.y), color_out
       If f > 0 Then
          PO2.x = PO2.x - 1
          f = ((PO2.x - PO.x) / A) * ((PO2.x - PO.x) / A) + ((PO2.y - PO.y) / B) * ((PO2.y - PO.y) / B) - 1
          flag = False
       Else
          flag = True
          PO2.y = PO2.y + 1
          f = ((PO2.x - PO.x) / A) * ((PO2.x - PO.x) / A) + ((PO2.y - PO.y) / B) * ((PO2.y - PO.y) / B) - 1
       End If
       If PO2.x < PO.x Then i1 = True
   Wend
End Sub

Public Sub setColor(pc As PictureBox, PO As Point, color)
   Dim flag As Boolean
   Dim mColor As Long
   Dim oldx As Integer
   Dim PO1 As Sck
   Dim left As Integer
   Dim right As Integer
   Dim left1 As Integer
   
   On Error GoTo ex
   If color = pc.Point(PO.x, PO.y) Then Exit Sub
   flag = False
   scnt = 1
   mColor = pc.Point(PO.x, PO.y)
   PO1.x = PO.x
   PO1.y = PO.y
   PO1.xleft = PO.x
 
   
   While (flag = False)
      If (pc.Point(PO1.x, PO1.y) <> color) Then
          oldx = PO1.x
          While (pc.Point(oldx, PO1.y) = mColor And oldx > 0)
             pc.PSet (oldx, PO1.y), color
             oldx = oldx - 1
          Wend
          left = oldx + 1
          oldx = PO1.x
          oldx = oldx + 1
          While (pc.Point(oldx, PO1.y) = mColor And oldx < pc.width)
             pc.PSet (oldx, PO1.y), color
             oldx = oldx + 1
          Wend
          oldx = oldx - 1
          
          If (Abs(PO1.xleft - left) > 1) Then
                GetSpecialPoint pc, stack, PO1.xleft, left, PO1.y, mColor
          End If
         
          If (pc.Point(oldx, PO1.y - 1) = mColor) Then
             right = oldx
          Else
             right = oldx - 1
             While (pc.Point(right, PO1.y - 1) <> mColor And right > 0)
                right = right - 1
             Wend
          End If
          If (right > left) Then
                stack(scnt).x = right
                stack(scnt).y = PO1.y - 1
                stack(scnt).xleft = left
                scnt = scnt + 1
                If scnt > mMax Then
                  MsgBox "too complicated picture!" & scnt
                  Exit Sub
                End If
          End If
          
          If (pc.Point(oldx, PO1.y + 1) = mColor) Then
             right = oldx
          Else
             right = oldx - 1
             While (pc.Point(right, PO1.y + 1) <> mColor And right > 0)
                right = right - 1
             Wend
          End If
        If (right > left) Then
           stack(scnt).x = right
           stack(scnt).y = PO1.y + 1
           stack(scnt).xleft = left
           scnt = scnt + 1
           If scnt > mMax Then
             MsgBox "too complicated picture!" & scnt
           Exit Sub
           End If
        End If
    End If
    
    If (scnt = 1) Then
       flag = True
    Else
       scnt = scnt - 1
       PO1.x = stack(scnt).x
       PO1.y = stack(scnt).y
       PO1.xleft = stack(scnt).xleft
    End If
   
   Wend
   
   Exit Sub
ex:
 MsgBox Err.Description & "as"
 'MsgBox scnt
End Sub

Private Sub GetSpecialPoint(pc As PictureBox, stack() As Sck, oleft As Integer, left As Integer, y As Integer, mColor)
   Dim lx As Integer
   Dim lx1 As Integer
   Dim ly As Integer
   Dim right As Integer
On Error GoTo ex
    
    If (left > oleft) Then
        lx1 = left
        ly = y
        Do
            lx = lx1 - 2
            If (pc.Point(lx, ly) = mColor) Then
               right = lx
            Else
               While (pc.Point(lx, ly) <> mColor And lx > 0)
                 lx = lx - 1
               Wend
               right = lx + 1
            End If

            If (right <= oleft) Then Exit Sub
            right = right - 1
            stack(scnt).x = right
            stack(scnt).y = ly
            stack(scnt).xleft = left
            
            'If scnt > 1 Then
            ' If stack(scnt).X = stack(scnt - 1).X And stack(scnt).Y = stack(scnt - 1).Y Then
            '  MsgBox "dd": Exit Sub
            ' End If
            'End If
            
            scnt = scnt + 1
            lx1 = right + 1
            If scnt > mMax Then
              MsgBox "too complicated picture!" & scnt
              Exit Sub
            End If
            While (pc.Point(right, ly) = mColor) And right < pc.width
               right = right - 1
            Wend
            right = right + 2
            lx1 = right
         Loop While (lx1 > oleft)
    End If
 Exit Sub
ex:
 MsgBox Err.Description & "ee"
End Sub

Sub ReDrawArea()
 ExecSource "setbackcolor[white];clear;"
 ExecSource frmMethord.txtMethord.Text
 frmDraw.PicBak.Picture = frmDraw.PicDraw.Image
 frmDraw.PicBak.Refresh
End Sub