📄 曲面_网状立体图f2.frm
字号:
VERSION 5.00
Begin VB.Form frmSurface
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "立体图"
ClientHeight = 8250
ClientLeft = 165
ClientTop = 735
ClientWidth = 13815
LinkTopic = "Form1"
ScaleHeight = 14.552
ScaleMode = 7 'Centimeter
ScaleWidth = 24.368
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox txtTZ
Alignment = 2 'Center
Appearance = 0 'Flat
Height = 270
Left = 12480
TabIndex = 8
Text = "1"
Top = 2520
Width = 855
End
Begin VB.TextBox txtTH
Alignment = 2 'Center
Appearance = 0 'Flat
Height = 270
Left = 12480
TabIndex = 6
Text = "1"
Top = 1800
Width = 855
End
Begin VB.TextBox txtGAMMA
Alignment = 2 'Center
Appearance = 0 'Flat
Height = 270
Left = 12480
TabIndex = 4
Text = "30"
Top = 1080
Width = 855
End
Begin VB.TextBox txtALPHA
Alignment = 2 'Center
Appearance = 0 'Flat
Height = 270
Left = 12480
TabIndex = 2
Text = "30"
Top = 360
Width = 855
End
Begin VB.PictureBox pic
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 8055
Left = 240
ScaleHeight = 14.155
ScaleMode = 7 'Centimeter
ScaleWidth = 20.929
TabIndex = 0
Top = 0
Width = 11895
Begin VB.Label lblTitle
Alignment = 2 'Center
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
Caption = "图题"
DragMode = 1 'Automatic
BeginProperty Font
Name = "隶书"
Size = 21.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 435
Left = 2175
TabIndex = 9
Top = 0
Width = 915
End
End
Begin VB.Label lblTZ
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "垂直伸缩"
ForeColor = &H80000008&
Height = 255
Left = 12360
TabIndex = 7
Top = 2280
Width = 1095
End
Begin VB.Label lblTH
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "数据点间距"
ForeColor = &H80000008&
Height = 255
Left = 12360
TabIndex = 5
Top = 1560
Width = 1095
End
Begin VB.Label lblGAMMA
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "视角（0-90）"
ForeColor = &H80000008&
Height = 255
Left = 12120
TabIndex = 3
Top = 840
Width = 1695
End
Begin VB.Label lblALPHA
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "旋转角（0-360）"
ForeColor = &H80000008&
Height = 255
Left = 12240
TabIndex = 1
Top = 120
Width = 1695
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 mnuData
Caption = "数据处理"
Begin VB.Menu mnuRow
Caption = "数据行倒转"
End
Begin VB.Menu mnuCol
Caption = "数据列倒转"
End
Begin VB.Menu mnuADD
Caption = "加常数（+或-）"
End
Begin VB.Menu mnuMul
Caption = "乘因子"
End
Begin VB.Menu mnuReNew
Caption = "恢复为原始数据"
End
End
End
Attribute VB_Name = "frmSurface"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim I As Integer, J As Integer, D As Double
Dim XY() As Double
Dim X() As Double, Y() As Double
Dim TH As Double, TZ As Double '数据点间距和垂直缩放系数
Dim ALPHA As Double, GAMMA As Double '旋转角和视角
'绘网格线
'L为切割方式。L=1，垂直Y轴切割；L=2，垂直X轴切割
'M为数据的行数
'N为数据的列数
Private Sub DL(L As Integer, M As Integer, N As Integer)
Dim IC As Integer, I As Integer, J As Integer, K As Integer
Dim GN As Integer, GM As Integer
Dim A As Integer, B As Integer, C As Integer, D As Double
Dim T() As Double, F() As Double, C1 As Double
Dim HH(-1000 To 1000) As Double '隐藏线数组
ReDim X(1 To N), Y(1 To N)
For I = -1000 To 1000
HH(I) = -200 '给隐藏线数组赋绝对值大的负数为初值
Next I
GN = 0: GM = 0
IC = -1
L1:
GM = GM + 1
K = 1
IC = -IC
GN = GN + IC
For J = 1 To N
If L = 1 Then
X(J) = XY(GM, J, 1) * 10
Y(J) = XY(GM, J, 2)
Else
X(J) = XY(J, GM, 1) * 10
Y(J) = XY(J, GM, 2)
End If
Next J
If X(1) > X(N) Then
For J = 1 To N \ 2
D = X(J)
X(J) = X(N - J + 1)
X(N - J + 1) = D
D = Y(J)
Y(J) = Y(N - J + 1)
Y(N - J + 1) = D
Next J
End If
C = X(N) - X(1)
ReDim T(1 To C), F(1 To C)
C1 = C + 0.000001
For J = 1 To C
T(J) = X(1) + ((X(N) - X(1)) / (C1 - 1)) * (J - 1)
Next J
LIP N, X, Y, C, T, F '线性插值
For J = 1 To C
'作隐藏线处理
If F(J) > HH(T(J) + 0.5) Then HH(T(J) + 0.5) = F(J)
Next J
L2:
If K = 1 Then
'这是新的一条线，需要确定当前坐标
pic.CurrentX = T(GN) / 10
pic.CurrentY = HH(T(GN) + 0.5)
Else
pic.Line -(T(GN) / 10, HH(T(GN) + 0.5)) '画线
End If
K = 3
GN = GN + IC
If GN > 0 And GN < C + 1 Then GoTo L2 '一条线未画完
If GM <= M - 1 Then GoTo L1 '开始新的一条线
End Sub
'立体图过程
'S：物体的切割方式。S=1，垂直Y轴切割；S=2，垂直X轴切割；S=3，双向切割
'ALPHA：旋转角，0-360度
'GAMMA：视角，0-90度
'M：数据的行数
'N：数据的列数
'Z：保存绘图数据的数组，网格节点上的高度值
'TH：网格的边长。要求网格在X方向和Y方向是一样的
'TZ：垂直方向的缩放系数
Private Sub Surface(S As Integer, ALPHA As Double, GAMMA As Double, _
M As Integer, N As Integer, Z() As Double, TH As Double, TZ As Double)
Dim I As Integer, J As Integer
Dim BB As Double, DD As Double
Dim A As Double, B As Double, C As Double, D As Double, E As Double
Dim F As Double, G As Double
Const P = 3.141592653: Const Q = 0.01745329
ReDim XY(1 To M, 1 To N, 1 To 2)
A = Sin(GAMMA * Q): B = Sin(ALPHA * Q): C = Cos(ALPHA * Q)
D = Sqr(1 - B * B * A * A): E = Sqr(1 - C * C * A * A)
F = Sqr(1 - (C / D) ^ 2): G = Sqr(1 - (B / E) ^ 2)
If F < 0.000001 Then F = 0.000001
If G < 0.000001 Then G = 0.000001
BB = P / 2 - Atn((C / D) / F)
DD = P / 2 - Atn((B / E) / G)
For I = 1 To M
For J = 1 To N
XY(I, J, 1) = TH * (J - 1) * D * Cos(BB) - TH * (I - 1) * E * Cos(DD)
XY(I, J, 2) = TH * (J - 1) * D * Sin(BB) + _
TH * (I - 1) * E * Sin(DD) - Abs(TZ) * Z(I, J) * A
Next J
Next I
If S = 1 Then DL 1, M, N '沿物体X方向切割
If S = 2 Then DL 2, N, M '沿物体Y方向切割
If S = 3 Then '双向切割
DL 1, M, N
DL 2, N, M
End If
End Sub
Private Sub Form_Load()
Me.Top = 0
Me.Left = 0
lblTitle.Caption = strLabelName '图题
mnuMove.Enabled = False
End Sub
'屏幕绘图
Private Sub mnuDraw_Click()
Dim WW As Double, WX As Double, WY As Double
pic.Cls '清除屏幕
TH = Val(txtTH.Text) '数据点间距
WX = TH * (N - 1): WY = TH * (M - 1)
If WX > WY Then WW = WX Else WW = WY
'建立自定义坐标系
pic.Scale (-1.2 * WW / TH, -1.2 * WW / TH)-(1.8 * WW / TH, 1.8 * WW / TH)
ALPHA = Val(txtALPHA.Text): GAMMA = 90 - Val(txtGAMMA.Text)
TZ = Val(txtTZ.Text) '数据值在垂直方向的放大系数
If ALPHA < 90 Then
If ALPHA < 1 Then ALPHA = 1
Surface 3, ALPHA, GAMMA, M, N, U, TH, TZ '旋转角在90度内
'******************************************************************
ElseIf ALPHA >= 90 And ALPHA < 180 Then '90----180
ALPHA = ALPHA - 90 '将旋转角变为锐角
If ALPHA < 1 Then ALPHA = 1
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
Surface 3, ALPHA, GAMMA, N, M, V, TH, TZ '旋转角在90-180度
'*******************************************************************
ElseIf ALPHA >= 180 And ALPHA < 270 Then '180----270
ALPHA = ALPHA - 180 '将旋转角变为锐角
If ALPHA < 1 Then ALPHA = 1
For I = 1 To intRow '列倒转
For J = 1 To intCol \ 2
D = U(I, intCol - J + 1)
U(I, intCol - J + 1) = U(I, J)
U(I, J) = D
Next J
Next I
For I = 1 To intRow \ 2 '行倒转
For J = 1 To intCol
D = U(intRow - I + 1, J)
U(intRow - I + 1, J) = U(I, J)
U(I, J) = D
Next J
Next I
Surface 3, ALPHA, GAMMA, M, N, U, TH, TZ '旋转角在180-270度
'*******************************************************************
ElseIf ALPHA >= 270 And ALPHA < 360 Then '270----360
ALPHA = ALPHA - 270 '将旋转角变为锐角
If ALPHA < 1 Then ALPHA = 1
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
Surface 3, ALPHA, GAMMA, N, M, V, TH, TZ '旋转角在270-360度
'********************************************************************
Else
MsgBox "旋转角应该小于360度！"
Exit Sub
End If
mnuMove.Enabled = True
End Sub
'退出，结束程序运行
Private Sub mnuExit_Click()
Unload Me
frmFileName.Visible = True
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
'自动拖放图题
'保存“图题”的标签的DragMode属性在属性窗口设置为1-Automatic
Private Sub pic_DragDrop(Source As Control, X As Single, Y As Single)
Source.Move X, Y
End Sub
'数据行倒转
Private Sub mnuRow_Click()
For I = 1 To intRow \ 2
For J = 1 To intCol
D = U(intRow - I + 1, J)
U(intRow - I + 1, J) = U(I, J)
U(I, J) = D
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()
For I = 1 To intRow
For J = 1 To intCol \ 2
D = U(I, intCol - J + 1)
U(I, intCol - J + 1) = U(I, J)
U(I, J) = D
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 mnuADD_Click()
Dim sngAdd As Single
sngAdd = InputBox("键入常数（正数或负数)")
For I = 1 To intRow
For J = 1 To intCol
U(I, J) = U(I, J) + sngAdd
V(J, I) = V(J, I) + sngAdd
Next J
Next I
End Sub
'因子处理
Private Sub mnuMul_Click()
Dim sngMul As Single
sngMul = InputBox("键入因子")
For I = 1 To intRow
For J = 1 To intCol
U(I, J) = U(I, J) * sngMul
V(J, I) = V(J, I) * sngMul
Next J
Next I
End Sub
'恢复原始数据
Private Sub mnuReNew_Click()
For I = 1 To intRow
For J = 1 To intCol
U(I, J) = U1(I, J)
V(J, I) = V1(J, I)
Next J
Next I
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -