?? 曲面_彩色等值線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 + -