📄 曲面_彩色等值线f2.frm
字号:
VERSION 5.00
Begin VB.Form frmContour
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "彩色等值线图"
ClientHeight = 8040
ClientLeft = 165
ClientTop = 735
ClientWidth = 15240
LinkTopic = "Form1"
ScaleHeight = 14.182
ScaleMode = 7 'Centimeter
ScaleWidth = 26.882
StartUpPosition = 3 '窗口缺省
Begin VB.PictureBox picLegend
Appearance = 0 'Flat
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 7935
Left = 12360
ScaleHeight = 7905
ScaleWidth = 2625
TabIndex = 2
Top = 0
Width = 2655
Begin VB.Label lblLegend
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "图例"
BeginProperty Font
Name = "隶书"
Size = 26.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 615
Left = 360
TabIndex = 3
Top = 0
Width = 1815
End
End
Begin VB.PictureBox pic
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 7935
Left = 120
ScaleHeight = 13.944
ScaleMode = 7 'Centimeter
ScaleWidth = 20.611
TabIndex = 0
Top = 0
Width = 11715
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 = 9360
TabIndex = 1
Top = 120
Width = 735
End
End
Begin VB.Menu mnuDraw
Caption = "作图"
End
Begin VB.Menu mnuExit
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 mnuSource
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 WW As Single
Dim I As Integer, J As Integer, K As Integer
Dim D As Double
'画彩色等值线过程
Private Sub Contour(M, N, DX, DY, S)
Dim legend(1 To 12) As Double, W As Double
K = 1
For W = PA To PB + 0.00000001 Step PC
legend(K) = W
K = K + 1
Next W
'画图例
picLegend.CurrentX = 0.5
picLegend.CurrentY = 1
For K = 1 To 12 '12个等级
picLegend.Line -(1, K + 1), QBColor(K), BF
picLegend.CurrentX = 0.5
picLegend.CurrentY = K + 1
Next K
'为图例写数字
For K = 1 To 12
picLegend.CurrentX = 1
picLegend.CurrentY = K + 0.3
picLegend.Print legend(K)
Next K
'根据网格点数值在网格点上画不同颜色的正方形
For I = 1 To M
For J = 1 To N
For K = 1 To 12
If S(I, J) < legend(K) + PC / 3 Then
pic.CurrentX = J * DX - DX / 2
pic.CurrentY = I * DY - DY / 2
pic.Line -(J * DX + DX / 2, I * DY + DY / 2), QBColor(K), BF
GoTo L
End If
Next K
L:
Next J
Next I
End Sub
Private Sub Form_Load()
Me.Top = 0
Me.Left = 0
Me.Height = 10000: Me.Width = 14600
'PA是初始等值线，缺省以最小值作为初始等值线值
'PB是终止等值线，缺省以最大值作为终止等值线值
'PC是等值线间距，缺省按12条等值线计算
PA = 100000000
PB = -100000000
For I = 1 To M
For J = 1 To N
If V(I, J) > PB Then PB = V(I, J)
If V(I, J) < PA Then PA = V(I, J)
Next J
Next I
PC = (PB - PA) / 11
DX = 1: DY = 1 '缺省设置间距为1厘米
lblTitle.Visible = False '图题标签不可视
mnuMove.Enabled = False '移动图题不可用
End Sub
'改变参数
Private Sub mnuChange_Click()
'在参数窗体显示参数
frmChange.txtX = Str(DX)
frmChange.txtY = Str(DY)
frmChange.Visible = True
End Sub
'屏幕绘图
Private Sub mnuDraw_Click()
pic.Cls
pic.ScaleMode = 7 '图片框以厘米为单位
picLegend.ScaleMode = 7 '图例图片框以厘米为单位
Printer.ScaleMode = 7 '打印机以厘米为单位
pic.Height = 16: pic.Width = 20
picLegend.Left = 20.5: picLegend.Height = 16
'如果点数很多，按厘米计会超出图幅，这时将使用自定义坐标系
If N * DX >= pic.Width Or M * DY >= pic.Height Then
If N * DX < 1.25 * M * DY Then
WW = M * DY
Else
WW = N * DX / 1.25
End If
'建立自定义坐标系
pic.Scale (0, 0)-(WW * 1.25, WW)
End If
lblTitle.Caption = strLabelName
Contour intM, intN, DX, DY, V
lblTitle.Visible = True '图题可视
mnuMove.Enabled = True '移动图题菜单可用
End Sub
'退出，结束程序运行
Private Sub mnuExit_Click()
Unload Me
frmFileName.Visible = True
End Sub
'将图片框pic的DragMode属性设为0-Manual，可以利用鼠标手动拖动pic
Private Sub pic_DragDrop(Source As Control, X As Single, Y As Single)
Source.Move X + pic.Left - sngX, Y + pic.Top - sngY
End Sub
'按下鼠标时记下pic的当前位置
Private Sub pic_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
sngX = X: sngY = Y
pic.Drag vbBeginDrag
End Sub
'下移标题
Private Sub mnuDown_Click()
lblTitle.Top = lblTitle.Top + 0.1
lblTitle.Move lblTitle.Left, lblTitle.Top
End Sub
'左移标题
Private Sub mnuLeft_Click()
lblTitle.Left = lblTitle.Left - 0.1
lblTitle.Move lblTitle.Left, lblTitle.Top
End Sub
'右移标题
Private Sub mnuRight_Click()
lblTitle.Left = lblTitle.Left + 0.1
lblTitle.Move lblTitle.Left, lblTitle.Top
End Sub
'上移标题
Private Sub mnuUP_Click()
lblTitle.Top = lblTitle.Top - 0.1
lblTitle.Move lblTitle.Left, lblTitle.Top
End Sub
'数据行和数据列都倒转
Private Sub mnuBoth_Click()
If intRow <> intCol Then
MsgBox "数据行数与数据列数不相等，不能交换数据！"
Exit Sub
End If
'数据列倒转
For I = 1 To intRow
For J = 1 To intCol \ 2
D = V(intCol - J + 1, I)
V(intCol - J + 1, I) = V(J, I)
V(J, I) = D
Next J
Next I
'数据行倒转
For I = 1 To intRow \ 2
For J = 1 To intCol
D = V(J, intRow - I + 1)
V(J, intRow - I + 1) = V(J, I)
V(J, I) = D
Next J
Next I
End Sub
'数据行倒转
Private Sub mnuRow_Click()
If intRow <> intCol Then
MsgBox "数据行数与数据列数不相等，不能交换数据！"
Exit Sub
End If
For I = 1 To intRow \ 2
For J = 1 To intCol
D = V(J, intRow - I + 1)
V(J, intRow - I + 1) = V(J, I)
V(J, I) = D
Next J
Next I
End Sub
'数据列倒转
Private Sub mnuCol_Click()
If intRow <> intCol Then
MsgBox "数据行数与数据列数不相等，不能交换数据！"
Exit Sub
End If
For I = 1 To intRow
For J = 1 To intCol \ 2
D = V(intCol - J + 1, I)
V(intCol - J + 1, I) = V(J, I)
V(J, I) = D
Next J
Next I
End Sub
'使用原始数据
Private Sub mnuSource_Click()
If intRow <> intCol Then
MsgBox "数据行数与数据列数不相等，不能交换数据！"
Exit Sub
End If
For I = 1 To intRow
For J = 1 To intCol
V(J, I) = V1(J, I)
Next J
Next I
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -