📄 movepic.frm
字号:
VERSION 5.00
Begin VB.Form MovePic
BorderStyle = 3 'Fixed Dialog
Caption = "动态图象计算"
ClientHeight = 5808
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 = "MovePic.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
PaletteMode = 1 'UseZOrder
ScaleHeight = 5808
ScaleWidth = 6600
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin VB.PictureBox PictureCompute
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 5535
Left = 120
ScaleHeight = 5484
ScaleWidth = 6324
TabIndex = 0
Top = 120
Width = 6375
Begin VB.PictureBox Picture2
Height = 4380
Left = 3240
ScaleHeight = 4332
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 = 4920
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 = 4380
Left = 120
ScaleHeight = 4332
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 = 2535
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 = "*.GRD"
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 = 4920
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 = 252
Index = 0
Left = 3240
TabIndex = 6
Top = 120
Width = 2892
End
End
End
Attribute VB_Name = "MovePic"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
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
Dim Index As String, QBColor15 As Long
If (bClick = False) Then Exit Sub
CommandOK.Enabled = False
bCompute = False
ListIn.Clear
If (FileInT.ListCount < 1) Then Exit Sub
On Error Resume Next
bClick = False
Screen.MousePointer = 11
N = FileInT.ListCount - 1
ReDim ParFill(0 To N, -1 To 2000), ParMove(0 To N)
QBColor15 = QBColor(15)
nMove = -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"
Case "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
nMove = nMove + 1
ParMove(nMove).Make = 0
ParMove(nMove).TheContouFile = FileInT.List(II)
ListIn.AddItem UCase(FileInT.List(II)) + "..."
For JJ = -1 To 2000
ParFill(nMove, JJ).FillColorInit = QBColor15
ParFill(nMove, JJ).MarkColorInit = QBColor15
Next JJ
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 CommandExit_Click()
bOKCancel = False
Unload Me
End Sub
Private Sub CommandOK_Click()
Dim I As Integer, J As Integer
nSelected = ListIn.SelCount
For I = 0 To ListIn.ListCount - 1
ParMove(I).Compute = ListIn.Selected(I)
Next I
IndexMove = ListIn.ListIndex
TheContouPath = TheInPath + ParMove(IndexMove).TheContouFile
LineToRegionStr = "等值线to区域"
MovePar.Show 1
If (bOKCancel = True) Then
bOKCancel = True
Unload Me
End If
End Sub
Private Sub dirin_Change()
If Len(DirIn.Path) <= 3 Then
TheInPath = DirIn.Path
Else
TheInPath = DirIn.Path + "\"
End If
FileInT.Path = DirIn.Path
End Sub
Private Sub dirin_LostFocus()
DirIn.Path = DirIn.List(DirIn.ListIndex)
End Sub
Private Sub driveIn_Change()
On Error GoTo DriveHandler
DirIn.Path = DriveIn.Drive
Exit Sub
DriveHandler:
DriveIn.Drive = DirIn.Path
Exit Sub
End Sub
Private Sub FileInT_PathChange()
Call SearchFile
End Sub
Private Sub FileInT_PatternChange()
Call SearchFile
End Sub
Private Sub Form_Load()
Dim TheInPathT As String
If (bMovePicture = True) Then
MovePic.Caption = "绘动态图像等值线图"
Else
MovePic.Caption = "绘等值线图"
End If
bClick = False
TheInPathT = ThePublicInPath
DriveIn.Drive = Left(TheInPathT, 2)
DirIn.Path = TheInPathT
bClick = True
TheInPath = TheInPathT
Call SearchFile
End Sub
Private Sub InIndex_Change()
On Error Resume Next
FileInT.Pattern = InIndex.Text
End Sub
Private Sub ListIn_Click()
If (ListIn.SelCount > 0) Then
CommandOK.Enabled = True
Else
CommandOK.Enabled = False
End If
End Sub
Private Sub ListIn_DblClick()
TheInFile = Trim(ParMove(ListIn.ListIndex).TheContouFile)
F2View.Show 1
End Sub
Private Sub ListIn_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13 Or KeyCode = 113) Then
TheInFile = Trim(ParMove(ListIn.ListIndex).TheContouFile)
F2View.Show 1
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -