form1.frm

这是一个线段压缩算法。用VB实现

VERSION 5.00
Begin VB.Form Form1 
   AutoRedraw      =   -1  'True
   BackColor       =   &H00808000&
   Caption         =   "道格拉斯-普克压缩"
   ClientHeight    =   8820
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   10095
   DrawWidth       =   2
   ForeColor       =   &H00000000&
   LinkTopic       =   "Form1"
   ScaleHeight     =   8983.333
   ScaleMode       =   0  'User
   ScaleWidth      =   10095
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command3 
      Caption         =   "Win"
      Height          =   495
      Left            =   8760
      TabIndex        =   3
      Top             =   1800
      Width           =   1095
   End
   Begin VB.PictureBox Picture1 
      AutoRedraw      =   -1  'True
      DrawWidth       =   2
      Height          =   8295
      Left            =   120
      ScaleHeight     =   8235
      ScaleWidth      =   8235
      TabIndex        =   2
      Top             =   120
      Width           =   8295
   End
   Begin VB.CommandButton Command2 
      Cancel          =   -1  'True
      Caption         =   "Exit"
      Height          =   495
      Left            =   8760
      TabIndex        =   1
      Top             =   7800
      Width           =   1095
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Clear"
      Default         =   -1  'True
      Height          =   495
      Left            =   8760
      TabIndex        =   0
      Top             =   600
      Width           =   1095
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim x1 As Double: Dim y1 As Double
Dim x2 As Double: Dim y2 As Double
Dim start As Boolean
Option Base 1
Dim Point0() As Double
Dim pointx() As Double
Dim pointy() As Double
Dim num As Integer
Dim GoOn As Integer


Private Sub Command1_Click()
Picture1.Cls
Call Form_Load
x1 = 0: y1 = 0
x2 = 0
y2 = 0
num = 0
Erase Point0, pointx, pointy
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Command3_Click()
Dim units As String
units = InputBox("请输入压缩精度:", "设定精度", 200)

Call press(Point0, pointx, pointy, Val(units), LBound(Point0), UBound(Point0))

Picture1.Cls
Call Form_Load


Dim i As Integer
CurrentX = pointx(1): CurrentY = pointy(1)
Picture1.Circle (pointx(1), pointy(1)), 30, RGB(0, 0, 255)

For i = 1 To UBound(Point0) - 1
    Picture1.Circle (pointx(i), pointy(i)), 30, RGB(0, 0, 255)
    Picture1.Line (pointx(i), pointy(i))-(pointx(i + 1), pointy(i + 1)), RGB(255, 0, 0)
Next i
Picture1.Circle (pointx(i), pointy(i)), 30, RGB(0, 0, 255)

End Sub

Private Sub Form_Load()
Show
Form1.Move 0, 0
Form1.Height = 9100
Form1.Width = 10200
start = True


Dim i, j As Integer
For i = 200 To 8000 Step 200
    For j = 200 To 8000 Step 200
        Picture1.Line (i, 200)-(i, 8000), RGB(0, 255, 255)
        Picture1.Line (200, j)-(8000, j), RGB(0, 255, 255)
    Next
Next

End Sub





Private Sub Label1_Click()

End Sub

Private Sub Picture1_DblClick()

    GoOn = MsgBox("是否停止", 36, "询问框")
    If GoOn = 6 Then
        start = False
    End If
End Sub

Private Sub Picture1_Mousedown(Button As Integer, Shift As Integer, x As Single, y As Single)
If start Then
    x1 = x2: y1 = y2
    x2 = x: y2 = y
    num = num + 1
    ReDim Preserve Point0(num)
    ReDim Preserve pointx(num)
    ReDim Preserve pointy(num)
    pointx(num) = Round(x, 3): pointy(num) = Round(y, 3)

    Picture1.Circle (x, y), 30, RGB(0, 0, 255)

    If x1 <> 0 & y1 <> 0 Then      ''& X <= 8000 & Y <= 8000 & Y >= 200 & X >= 200
            Picture1.Line (x1, y1)-(x2, y2), RGB(255, 0, 0)
    End If

End If

End Sub