📄 slope.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Slope
BorderStyle = 3 'Fixed Dialog
Caption = "坡度、坡向分析"
ClientHeight = 6012
ClientLeft = 840
ClientTop = 168
ClientWidth = 6600
BeginProperty Font
Name = "宋体"
Size = 11.4
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "Slope.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
PaletteMode = 1 'UseZOrder
ScaleHeight = 6012
ScaleWidth = 6600
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin MSComctlLib.ProgressBar ProgressBar1
Height = 192
Left = 60
TabIndex = 12
Top = 5820
Visible = 0 'False
Width = 6552
_ExtentX = 11557
_ExtentY = 339
_Version = 393216
Appearance = 1
End
Begin VB.PictureBox PictureCompute
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 5652
Left = 120
ScaleHeight = 5604
ScaleWidth = 6324
TabIndex = 0
Top = 120
Width = 6375
Begin VB.PictureBox Picture2
Height = 4500
Left = 3240
ScaleHeight = 4452
ScaleWidth = 2844
TabIndex = 9
Top = 360
Width = 2892
Begin VB.TextBox InIndex
Height = 360
Left = 120
TabIndex = 11
Text = "*.GRD"
Top = 120
Width = 2535
End
Begin VB.ListBox ListIn
Height = 3696
Left = 120
MultiSelect = 2 'Extended
TabIndex = 10
Top = 600
Width = 2532
End
End
Begin VB.CommandButton CommandExit
Caption = "退出"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 4200
TabIndex = 8
Top = 5040
Width = 1335
End
Begin VB.PictureBox Picture1
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 4500
Left = 120
ScaleHeight = 4452
ScaleWidth = 2844
TabIndex = 3
Top = 360
Width = 2895
Begin VB.DriveListBox DriveIn
Height = 324
Left = 120
TabIndex = 5
Top = 120
Width = 2535
End
Begin VB.DirListBox DirIn
Height = 3600
Left = 120
TabIndex = 4
Top = 600
Width = 2532
End
End
Begin VB.FileListBox FileInT
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 432
Left = 3720
MultiSelect = 1 'Simple
Pattern = "*.GRV"
TabIndex = 2
Top = 1320
Visible = 0 'False
Width = 1575
End
Begin VB.CommandButton CommandOK
Caption = "开始计算"
Enabled = 0 'False
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 720
TabIndex = 1
Top = 5040
Width = 1335
End
Begin VB.Label lblCriteria
Alignment = 2 'Center
Caption = "文件路径"
BeginProperty Font
Name = "宋体"
Size = 11.4
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 7
Top = 120
Width = 2895
End
Begin VB.Label Label1
Alignment = 2 'Center
Caption = "文件属性"
BeginProperty Font
Name = "宋体"
Size = 11.4
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 0
Left = 3240
TabIndex = 6
Top = 120
Width = 2895
End
End
End
Attribute VB_Name = "Slope"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim TheInPath As String, TheInFile As String
Dim bClick As Boolean
Dim DataType As Integer
Private Sub SearchFile()
Dim I As Integer, J As Integer, K As Integer, L As Integer, N As Integer, Temp As String
Dim II As Integer, I1 As Integer, TheContouPath As String, JJ As Integer
Dim DSAA_DSBB As String * 4, Index As String
On Error Resume Next
If (bClick = False) Then Exit Sub
CommandOK.Enabled = False
ListIn.Clear
If (FileInT.ListCount < 1) Then Exit Sub
bClick = False
Screen.MousePointer = 11
N = FileInT.ListCount - 1
For II = 0 To N
TheContouPath = TheInPath + FileInT.List(II)
I = InStr(TheContouPath, ".")
If (I > 0) Then
Index = Right(TheContouPath, Len(TheContouPath) - I)
Else
Index = ""
End If
Select Case Index
Case "BMP", "GIF", "JPG", "ICO", "DIB", "WMF", "EMF", "TIF", "PCX"
Case "SHK", "WKF", "EQT", "EQ2", "C01", "RRR", "999", "MRP"
Case "EXE", "COM", "FRX", "FRM", "VGA", "EGA", "BIN", "DLL", "LIB", "ARJ", "OCX", "OCA", "DB2", "DOC", "TMP", "LIN", "MAP", "IND", "ID", "TAB", "WOR"
Case "MDB", "DBF"
Case Else
Open TheContouPath For Binary Access Read Lock Read As #1
Get #1, 1, DSAA_DSBB
Close (1)
If (DSAA_DSBB = "DSAA" Or DSAA_DSBB = "DSBB" Or DSAA_DSBB = "DSRB") Then
K = 3
Else
'判断一行有几个数
Open TheContouPath For Input As #1
For I = 1 To 3
Line Input #1, Temp
Temp = Trim(Temp)
J = Len(Temp)
I1 = 2
K = 1
Do While I1 < J
If (Mid(Temp, I1, 1) = " " Or Mid(Temp, I1, 1) = ",") Then
K = K + 1
For L = I1 + 1 To J
If (Mid(Temp, L, 1) = " " Or Mid(Temp, L, 1) = ",") Then
I1 = L
Else
I1 = I1 + 1
Exit For
End If
Next L
Else
I1 = I1 + 1
End If
Loop
If (K <> 3) Then Exit For
Next I
Close (1)
End If
If (K = 3) Then
ListIn.AddItem UCase(FileInT.List(II)) + "..."
End If
End Select
Next II
If (ListIn.SelCount > 0) Then
CommandOK.Enabled = True
Else
CommandOK.Enabled = False
End If
Screen.MousePointer = 0
bClick = True
End Sub
'读绘等值线的数据
Private Sub ReadContouFile(TheContouPath As String, dx As Double, dy As Double, NX As Integer, NY As Integer, ZGrid() As Double, Xmin As Double, Xmax As Double, Ymin As Double, Ymax As Double, Vmin As Double, Vmax As Double)
Dim Xcontou() As Double, Ycontou() As Double, Zcontou() As Double, nContou As Long
Dim IX As Integer, IY As Integer, II As Integer
Dim I As Integer, J As Integer, K As Integer
Dim I1 As Integer, L As Integer, Temp As String, DSAA_DSBB As String * 4, ValueTemp As Single
Dim N0 As Long, N As Long
Dim Xt As Double, Yt As Double
Dim Lat As Double, Lon As Double, Rou As Double
Dim VminTMP As Double, VmaxTMP As Double
Dim iModeOld As Integer, StrMax As String
Dim bSpace As Boolean
Dim lNX As Long, lNY As Long, DouValueTemp As Double, xStep As Double, yStep As Double
Dim XminT As Double, XmaxT As Double, YminT As Double, YmaxT As Double, VminT As Double, VmaxT As Double
Open TheContouPath For Binary Access Read Lock Read As #1
Get #1, 1, DSAA_DSBB
Close (1)
If (DSAA_DSBB = "DSAA") Then
Open TheContouPath For Input As #1
Line Input #1, Temp
Input #1, NX, NY
Input #1, Xmin, Xmax
Input #1, Ymin, Ymax
Input #1, Vmin, Vmax
For IX = 1 To NX
Input #1, ValueTemp
Next IX
Line Input #1, Temp
Close (1)
If (Len(Trim(Temp)) < 1) Then
bSpace = True
Else
bSpace = False
End If
Close (1)
DataType = 0
Open TheContouPath For Input As #1
Line Input #1, Temp
Input #1, NX, NY
Input #1, Xmin, Xmax
Input #1, Ymin, Ymax
Input #1, Vmin, Vmax
ReDim ZGrid(1 To NX, 1 To NY)
dx = (Xmax - Xmin) / (NX - 1)
dy = (Ymax - Ymin) / (NY - 1)
Yt = Ymin - dy
If (bSpace = False) Then
For IY = 1 To NY
For IX = 1 To NX
Input #1, ZGrid(IX, IY)
Next IX
Next IY
Else
For IY = 1 To NY
For IX = 1 To NX
Input #1, ZGrid(IX, IY)
Next IX
Line Input #1, Temp
Next IY
End If
Close (1)
ElseIf (DSAA_DSBB = "DSBB") Then
DataType = 0
Open TheContouPath For Binary Access Read Lock Read As #1
Seek #1, 5
Get #1, , NX
Get #1, , NY
Get #1, , Xmin
Get #1, , Xmax
Get #1, , Ymin
Get #1, , Ymax
Get #1, , Vmin
Get #1, , Vmax
ReDim ZGrid(1 To NX, 1 To NY)
dx = (Xmax - Xmin) / (NX - 1)
dy = (Ymax - Ymin) / (NY - 1)
For IY = 1 To NY
For IX = 1 To NX
Get #1, , ValueTemp
ZGrid(IX, IY) = ValueTemp
Next IX
Next IY
Close (1)
ElseIf (DSAA_DSBB = "DSRB") Then
DataType = 0
Open TheContouPath For Binary Access Read Lock Read As #1
Seek #1, 17
Get #1, , lNY
Get #1, , lNY
Get #1, , lNX
Get #1, , XminT
Get #1, , YminT
Get #1, , xStep
Get #1, , yStep
Get #1, , VminT
Get #1, , VmaxT
NX = lNX
NY = lNY
dx = xStep
dy = yStep
Xmin = XminT
Xmax = Xmin + (NX - 1) * xStep
Ymin = YminT
Ymax = Ymin + (NY - 1) * yStep
Vmin = VminT
Vmax = VmaxT
ReDim ZGrid(1 To NX, 1 To NY)
Seek #1, 101
For IY = 1 To NY
For IX = 1 To NX
Get #1, , DouValueTemp
ZGrid(IX, IY) = DouValueTemp
Next IX
Next IY
Close (1)
Else
'判断一行有几个数
Open TheContouPath For Input As #1
For I = 1 To 3
Line Input #1, Temp
Temp = Trim(Temp)
J = Len(Temp)
I1 = 2
K = 1
Do While I1 < J
If (Mid(Temp, I1, 1) = " " Or Mid(Temp, I1, 1) = ",") Then
K = K + 1
For L = I1 + 1 To J
If (Mid(Temp, L, 1) = " " Or Mid(Temp, L, 1) = ",") Then
I1 = L
Else
I1 = I1 + 1
Exit For
End If
Next L
Else
I1 = I1 + 1
End If
Loop
If (K <> 3) Then Exit For
Next I
Close (1)
If (K <> 3) Then
'非本程序识别格式
NX = 0
NY = 0
Exit Sub
End If
N0 = 1000
ReDim Xcontou(0 To N0), Ycontou(0 To N0), Zcontou(0 To N0)
N = -1
Open TheContouPath For Input As #1
Do While Not EOF(1)
N = N + 1
If (N > N0) Then
N0 = N0 + 100
ReDim Preserve Xcontou(0 To N0), Ycontou(0 To N0), Zcontou(0 To N0)
End If
Input #1, Ycontou(N), Xcontou(N), Zcontou(N)
Loop
nContou = N
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -