📄 form1.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1
Caption = "插值长度"
ClientHeight = 7710
ClientLeft = 120
ClientTop = 420
ClientWidth = 14280
LinkTopic = "Form1"
ScaleHeight = 7710
ScaleWidth = 14280
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox Text3
Height = 270
Left = 8880
TabIndex = 11
Text = "0"
Top = 120
Width = 1455
End
Begin VB.CommandButton Command1
Caption = "Unload Me"
Height = 255
Left = 10680
TabIndex = 1
Top = 120
Width = 1215
End
Begin VB.CommandButton Command4
Caption = "Length Test"
Height = 255
Left = 6720
TabIndex = 9
Top = 120
Width = 1215
End
Begin VB.CommandButton Command7
Caption = "4"
Height = 615
Left = 4680
TabIndex = 8
Top = 0
Visible = 0 'False
Width = 375
End
Begin VB.CommandButton Command6
Caption = "3"
Height = 615
Left = 4320
TabIndex = 7
Top = 0
Visible = 0 'False
Width = 375
End
Begin VB.CommandButton Command5
Caption = "2"
Height = 615
Left = 3960
TabIndex = 6
Top = 0
Visible = 0 'False
Width = 375
End
Begin VB.CommandButton Command3
Caption = "Retest"
Height = 255
Left = 5400
TabIndex = 5
Top = 120
Width = 975
End
Begin VB.TextBox Text2
Height = 270
Left = 8640
TabIndex = 4
Text = "0"
Top = 6240
Visible = 0 'False
Width = 1095
End
Begin VB.CommandButton Command2
Caption = "Load Picture"
Height = 255
Left = 120
TabIndex = 3
Top = 120
Width = 1335
End
Begin MSComDlg.CommonDialog cmdg1
Left = 9840
Top = 2160
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.TextBox Text1
Height = 270
Left = 3600
TabIndex = 2
Text = "3"
Top = 120
Width = 375
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
Height = 3135
Left = 0
Picture = "Form1.frx":0000
ScaleHeight = 3075
ScaleWidth = 13395
TabIndex = 0
Top = 600
Width = 13455
Begin VB.CommandButton Command8
Caption = "Command8"
Height = 375
Left = 1320
TabIndex = 13
Top = 1080
Visible = 0 'False
Width = 1335
End
End
Begin VB.Label Label2
Caption = "Result"
Height = 255
Left = 8280
TabIndex = 12
Top = 120
Width = 615
End
Begin VB.Label Label1
Caption = "Insert Point Number"
Height = 255
Left = 1800
TabIndex = 10
Top = 120
Width = 1815
End
End
Attribute VB_Name = "form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Command2_Click()
cmdg1.Filter = "All Image Files|*.bmp;*.jpg;*.gif| "
cmdg1.ShowOpen
Picture1.Picture = LoadPicture(cmdg1.FileName)
Text2 = 0
mypoint = 0
mycount = 0
ReDim myx(0)
ReDim myy(0)
fangchengshuliang = 0
ReDim chazhicishu(fangchengshuliang)
Picture1.Cls
End Sub
Private Sub Command3_Click()
Text2 = 0
mypoint = 0
mycount = 0
ReDim myx(0)
ReDim myy(0)
fangchengshuliang = 0
ReDim chazhicishu(fangchengshuliang)
Picture1.Cls
End Sub
Private Sub Command4_Click()
Dim lll As Single
Dim i As Single
For i = 1 To fangchengshuliang
lll = lll + mylength(i)
Next i
Text3 = lll
End Sub
Private Sub Command5_Click()
Text1.Text = 2
End Sub
Private Sub Command6_Click()
Text1.Text = 3
End Sub
Private Sub Command7_Click()
Text1.Text = 4
End Sub
Private Sub Command8_Click()
Dim yy As Single
For i = 0 To 4000
yy = Sin(i * 3.14 / 2000) * 1000
Picture1.PSet (i, 1000 + yy), vbRed
Next i
End Sub
Private Sub Form_Load()
Me.Left = 0
Me.Top = 0
Me.Width = Screen.Width
Me.Height = Screen.Height
Picture1.Width = Me.Width
Picture1.Height = Me.Height
'''''''''''''
Picture1.Line (1000, 1000)-(1000, 5000)
Picture1.Line (1000, 1000)-(4000, 1000)
Picture1.Line (1000, 5000)-(4000, 1000)
Picture1.Circle (2500, 2500), 1500
End Sub
Private Sub Picture1_Click()
Text2.Text = UBound(myx)
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Single
Dim j As Single
Dim k As Single
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'判断坐标是否有重复，如果重复，则此次点击操作无效
Dim syn As Single
For i = mypoint - mycount + 1 To mypoint
If myx(i) = X Then syn = 1
Next i
If syn = 1 Then
syn = 0
Else
If Button = 1 Then
'左键，如果是左键，则画点
mycount = mycount + 1
mypoint = mypoint + 1
ReDim Preserve myx(mypoint) As Single
ReDim Preserve myy(mypoint) As Single
myx(mypoint) = X
myy(mypoint) = Y
'画点
Picture1.DrawWidth = 3
Picture1.PSet (X, Y), vbBlue
'Picture1.Print mypoint
Picture1.DrawWidth = 1
'画点结束
'判断点的数量是否达到要求
If mycount = Val(Text1) Then
'如果达到要求，画出插值曲线
'////////////////////////////////////////////////////////////////////////////////////////
fangchengshuliang = fangchengshuliang + 1
ReDim Preserve chazhicishu(fangchengshuliang) As Single
chazhicishu(fangchengshuliang) = Val(Text1.Text)
'//////////////////////////////判断开口方向//////////////////////////////////////////////
ReDim Preserve opendirection(fangchengshuliang)
Dim lsx1 As Single
Dim lsx2 As Single
Dim lsx3 As Single
Dim lsy1 As Single
Dim lsy2 As Single
Dim lsy3 As Single
lsx1 = myx(mypoint)
lsy1 = myy(mypoint)
lsx2 = myx(mypoint - 1)
lsy2 = myy(mypoint - 1)
lsx3 = myx(mypoint - 2)
lsy3 = myy(mypoint - 2)
'左右为1，上下为0
If (myx(mypoint - 1) > myx(mypoint - 2) And myx(mypoint - 1) > myx(mypoint)) Or (myx(mypoint - 1) < myx(mypoint - 2) And myx(mypoint - 1) < myx(mypoint)) Then
opendirection(fangchengshuliang) = 1
myx(mypoint) = myy(mypoint)
myx(mypoint - 1) = myy(mypoint - 1)
myx(mypoint - 2) = myy(mypoint - 2)
myy(mypoint) = lsx1
myy(mypoint - 1) = lsx2
myy(mypoint - 2) = lsx3
End If
'//////////////////////////////判断开口方向结束/////////////////////////////////////////
'求xa,xb
xa = myx(mypoint - mycount + 1)
xb = xa
For i = mypoint - mycount + 1 To mypoint
If myx(i) <= xa Then xa = myx(i)
If myx(i) >= xb Then xb = myx(i)
Next i
'求xa，xb结束
For i = xa To xb
If opendirection(fangchengshuliang) = 0 Then
If fangchengshuliang Mod 2 = 0 Then Picture1.PSet (i, Ln(i)), vbRed
If fangchengshuliang Mod 2 = 1 Then Picture1.PSet (i, Ln(i)), vbGreen
Else
If fangchengshuliang Mod 2 = 0 Then Picture1.PSet (Ln(i), i), vbRed
If fangchengshuliang Mod 2 = 1 Then Picture1.PSet (Ln(i), i), vbGreen
End If
Next i
''''''''''''''''''''''''''''''''''画线结束后，将更改方向时破坏的记录恢复
myx(mypoint) = lsx1
myy(mypoint) = lsy1
myx(mypoint - 1) = lsx2
myy(mypoint - 1) = lsy2
myx(mypoint - 2) = lsx3
myy(mypoint - 2) = lsy3
''''''''''''''''''''''''''''''''''恢复完成
'Picture1.Print fangchengshuliang
'画点结束，清除mycount
mycount = 1
End If
Else
'右键，如果是右键，则清除刚刚画过的插值曲线
If UBound(myx) > 1 Then
mycount = Val(Text1)
lsx1 = myx(mypoint)
lsy1 = myy(mypoint)
lsx2 = myx(mypoint - 1)
lsy2 = myy(mypoint - 1)
lsx3 = myx(mypoint - 2)
lsy3 = myy(mypoint - 2)
If opendirection(fangchengshuliang) = 1 Then
myx(mypoint) = myy(mypoint)
myx(mypoint - 1) = myy(mypoint - 1)
myx(mypoint - 2) = myy(mypoint - 2)
myy(mypoint) = lsx1
myy(mypoint - 1) = lsx2
myy(mypoint - 2) = lsx3
End If
xa = myx(mypoint - mycount + 1)
xb = xa
For i = mypoint - mycount + 1 To mypoint
If myx(i) <= xa Then xa = myx(i)
If myx(i) >= xb Then xb = myx(i)
Next i
For i = xa To xb
If opendirection(fangchengshuliang) = 1 Then
Picture1.PSet (Ln(i), i), BackColor
Else
Picture1.PSet (i, Ln(i)), BackColor
End If
Next i
''''''''''''''''''''''''''''''''''画线结束后，将更改方向时破坏的记录恢复
myx(mypoint) = lsx1
myy(mypoint) = lsy1
myx(mypoint - 1) = lsx2
myy(mypoint - 1) = lsy2
myx(mypoint - 2) = lsx3
myy(mypoint - 2) = lsy3
''''''''''''''''''''''''''''''''''恢复完成
mycount = 1
mypoint = mypoint - Val(Text1) + 1
ReDim Preserve myx(mypoint) As Single
ReDim Preserve myy(mypoint) As Single
fangchengshuliang = fangchengshuliang - 1
ReDim Preserve chazhicishu(fangchengshuliang) As Single
ReDim Preserve opendirection(fangchengshuliang)
'恢复被破坏的背景
Picture1.Picture = LoadPicture(cmdg1.FileName)
Dim lll As Single
For i = 1 To fangchengshuliang
Call myredraw(i, i Mod 2)
Next i
Picture1.DrawWidth = 3
For i = 1 To mypoint
Picture1.PSet (myx(i), myy(i)), vbBlue
Next i
Picture1.DrawWidth = 1
'擦除完成
End If
End If
End If
End Sub
Private Sub Picture2_Click()
End Sub
Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
End Sub
Private Sub Text1_Change()
If Text1.Text > 3 Then Text1.Text = 3
If Text1.Text < 2 Then Text1.Text = 2
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -