📄 曲面_等值线f2.frm
字号:
VERSION 5.00
Begin VB.Form frmContour
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "等值线图"
ClientHeight = 10185
ClientLeft = 165
ClientTop = 735
ClientWidth = 15240
LinkTopic = "Form1"
ScaleHeight = 17.965
ScaleMode = 7 'Centimeter
ScaleWidth = 26.882
StartUpPosition = 3 '窗口缺省
Begin VB.PictureBox pic
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &H80000005&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 8055
Left = 120
ScaleHeight = 14.208
ScaleMode = 7 'Centimeter
ScaleWidth = 23.31
TabIndex = 0
Top = 120
Width = 13215
Begin VB.Label lblMus
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "-"
BeginProperty Font
Name = "宋体"
Size = 15.75
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 170
Left = 7800
TabIndex = 3
Top = 1440
Width = 170
End
Begin VB.Label lblAdd
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "+"
BeginProperty Font
Name = "宋体"
Size = 15.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 227
Left = 7800
TabIndex = 2
Top = 600
Width = 227
End
Begin VB.Label lblTitle
Alignment = 2 'Center
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
Caption = "图题"
DragMode = 1 'Automatic
BeginProperty Font
Name = "隶书"
Size = 18
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 360
Left = 9840
OLEDropMode = 1 'Manual
TabIndex = 1
Top = 240
Width = 735
End
End
Begin VB.Menu mnuDraw
Caption = "作图"
End
Begin VB.Menu mnuExit
Caption = "退出"
End
Begin VB.Menu mnuPrint
Caption = "打印"
End
Begin VB.Menu mnuMove
Caption = "移动图题"
Begin VB.Menu mnuDown
Caption = "下移"
Shortcut = ^D
End
Begin VB.Menu mnuRight
Caption = "右移"
Shortcut = ^R
End
Begin VB.Menu mnuUP
Caption = "上移"
Shortcut = ^U
End
Begin VB.Menu mnuLeft
Caption = "左移"
Shortcut = ^L
End
End
Begin VB.Menu mnuChange
Caption = "改变参数"
End
Begin VB.Menu mnuInverse
Caption = "数据倒转"
Begin VB.Menu mnuRow
Caption = "行倒转"
End
Begin VB.Menu mnuCol
Caption = "列倒转"
End
Begin VB.Menu mnuBoth
Caption = "行和列都倒转"
End
Begin VB.Menu mnuReNew
Caption = "恢复原样"
End
End
Begin VB.Menu mnuCha
Caption = "移动符号"
Begin VB.Menu mnuAdd
Caption = "加号"
Begin VB.Menu mnuAD
Caption = "下移"
Shortcut = {F2}
End
Begin VB.Menu mnuAR
Caption = "右移"
Shortcut = {F4}
End
Begin VB.Menu mnuAU
Caption = "上移"
Shortcut = {F3}
End
Begin VB.Menu mnuAL
Caption = "左移"
Shortcut = {F1}
End
End
Begin VB.Menu mnuMus
Caption = "减号"
Begin VB.Menu mnuMD
Caption = "下移"
Shortcut = {F6}
End
Begin VB.Menu mnuMR
Caption = "右移"
Shortcut = {F8}
End
Begin VB.Menu mnuMU
Caption = "上移"
Shortcut = {F7}
End
Begin VB.Menu mnuML
Caption = "左移"
Shortcut = {F5}
End
End
End
Begin VB.Menu mnuCDel
Caption = "删除符号"
Begin VB.Menu mnuADel
Caption = "加号"
End
Begin VB.Menu mnuMDEL
Caption = "减号"
End
End
End
Attribute VB_Name = "frmContour"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'等值线图
'与系统所规定的屏幕坐标系一致
'既原点在左上角，Y方向向下为正，X方向向右为正
Option Explicit
Dim sngX As Single, sngY As Single
Dim intPrinter As Integer '=1，用打印机；=0，不用打印机
Dim WW As Single, D As Double
'1。计算等值线所穿过的网格边的整体坐标
'2。做记号表示等值线从网格穿过，避免重复
Private Sub FZ(I0, J0, S1)
'I0,J0是网格的标志号
'S1=0在网格的Y边上找到等值点
'S1=1在网格的X边上找到等值点
I3 = I0: J3 = J0
A3X = (J3 + S1 * S(I3, J3)) * DX '网格在X方向上的整体坐标
A3Y = (I3 + (1 - S1) * H(I3, J3)) * DY '网格在Y方向上的整体坐标
If S1 > 0.5 Then
S(I3, J3) = -2 '等值点在Y边
Else
H(I3, J3) = -2 '等值点在X边
End If
End Sub
'在一个网格中已经找到等值线所经过的起点和终点（A2X，A2Y）
'由这两个点在相邻的网格中去找未来点（A3X，A3Y）
'一旦找到未来点，则网格终点就变成起点，而未来点则变成终点
Private Sub FY()
On Error Resume Next
If I1 < I2 Then
If H(I2, J2) > 0 Then
FZ I2, J2, 0
Else
If H(I2, J2 + 1) > 0 Then
FZ I2, J2 + 1, 0
Else
FZ I2 + 1, J2, 1
End If
End If
Else
If J1 < J2 Then
If S(I2, J2) > 0 Then
FZ I2, J2, 1
Else
If S(I2 + 1, J2) > 0 Then
FZ I2 + 1, J2, 1
Else
FZ I2, J2 + 1, 0
End If
End If
Else
If J2 * DX < A2X Then
If H(I2 - 1, J2 + 1) > 0 Then
FZ I2 - 1, J2 + 1, 0
Else
If H(I2 - 1, J2) > 0 Then
FZ I2 - 1, J2, 0
Else
FZ I2 - 1, J2, 1
End If
End If
Else
If S(I2 + 1, J2 - 1) > 0 Then
FZ I2 + 1, J2 - 1, 1
Else
If S(I2, J2 - 1) > 0 Then
FZ I2, J2 - 1, 1
Else
FZ I2, J2 - 1, 0
End If
End If
End If
End If
End If
I1 = I2: J1 = J2: I2 = I3: J2 = J3
A2X = A3X: A2Y = A3Y
End Sub
'等值线追踪，并画等值线
Private Sub WF(I9, J9, S0, I0, J0)
Dim X As Double, Y As Double
'I9、J9和I0、J0为等值线所穿过的两个相连的网格的标志
I1 = I0: J1 = J0
A1X = (J9 + S0 * S(I9, J9)) * DX: A2X = A1X
A1Y = (I9 + (1 - S0) * H(I9, J9)) * DY: A2Y = A1Y
I2 = I9: J2 = J9
'移笔到（A2X，A2Y）
If intPrinter = 0 Then
pic.CurrentX = A2X: pic.CurrentY = A2Y
Else
Printer.CurrentX = A2X: Printer.CurrentY = A2Y
End If
G(K, 1) = A2X - DX: G(K, 2) = A2Y - DY: G(K, 3) = W
If K < 300 Then K = K + 1
BB1:
FY '寻找下一点
'画线到下一点（A2X，A2Y）
If intPrinter = 0 Then
pic.Line -(A2X, A2Y)
Else
Printer.Line -(A2X, A2Y)
End If
'判断是否停止追踪
If A1X = A2X And A1Y = A2Y Then GoTo AA1
If A2X = DX Or J2 = N Or A2Y = DY Or I2 = M Then GoTo AA1
GoTo BB1 '继续追踪
AA1:
'停止追踪
'打上不再是等值线头的标记
If S0 = 0 Then
H(I9, J9) = -2
Else
S(I9, J9) = -2
End If
End Sub
'画等值线过程
Private Sub Contour(M, N, DX, DY, S0)
Dim Vmax As Double, Vmin As Double
Dim Imax As Integer, Imin As Integer, Jmax As Integer, Jmin As Integer
K = 1
If intPrinter = 0 Then
pic.Line (DX, DY)-(N * DX, M * DY), , B '在屏幕上绘图框
Else
Printer.Line (DX, DY)-(N * DX, M * DY), , B '打印机绘图框
End If
Vmax = S0(1, 1): Vmin = S0(1, 1)
For I = 1 To M
For J = 1 To N
If S0(I, J) > Vmax Then
Vmax = S0(I, J): Imax = I: Jmax = J
End If
If S0(I, J) < Vmin Then
Vmin = S0(I, J): Imin = I: Jmin = J
End If
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -