www.pudn.com > gdqj1a302.zip > Fname.frm
VERSION 5.00
Begin VB.Form fmFname
BackColor = &H00808000&
BorderStyle = 0 'None
ClientHeight = 2925
ClientLeft = 2730
ClientTop = 2910
ClientWidth = 6870
KeyPreview = -1 'True
LinkMode = 1 'Source
LinkTopic = "Form1"
MinButton = 0 'False
PaletteMode = 1 'UseZOrder
ScaleHeight = 2925
ScaleWidth = 6870
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin VB.ComboBox Combo1
Height = 315
Left = 180
TabIndex = 10
Top = 990
Width = 2415
End
Begin VB.TextBox FullPath
Height = 375
Left = 5490
TabIndex = 9
Top = 2010
Visible = 0 'False
Width = 1215
End
Begin VB.TextBox Text1
Height = 315
Left = 180
TabIndex = 0
Top = 1650
Width = 2415
End
Begin VB.CommandButton Command1
Caption = "确认"
Default = -1 'True
Height = 375
Left = 5520
TabIndex = 3
Top = 480
Width = 1215
End
Begin VB.CommandButton Command2
Cancel = -1 'True
Caption = "取消"
Height = 375
Left = 5520
TabIndex = 4
Top = 1110
Width = 1215
End
Begin VB.DirListBox Dir1
Height = 1890
Left = 2940
TabIndex = 1
Top = 810
Width = 2265
End
Begin VB.DriveListBox Drive1
Height = 315
Left = 180
TabIndex = 2
Top = 2400
Width = 2415
End
Begin VB.Label Label3
AutoSize = -1 'True
BackColor = &H00808000&
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 4560
TabIndex = 12
Top = 210
Width = 735
End
Begin VB.Label Label6
AutoSize = -1 'True
BackColor = &H00808000&
Caption = "数采文件记录号:"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Left = 180
TabIndex = 11
Top = 690
Width = 1305
End
Begin VB.Label Label2
AutoSize = -1 'True
BackColor = &H00808000&
Caption = "存盘数据文件名:"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Left = 180
TabIndex = 8
Top = 1410
Width = 1305
End
Begin VB.Label Label1
AutoSize = -1 'True
BackColor = &H00808000&
Caption = "选择数采文件号和PC存储路径"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 360
TabIndex = 5
Top = 150
Width = 3930
End
Begin VB.Label Label4
AutoSize = -1 'True
BackColor = &H00808000&
Caption = "目录:"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Left = 3000
TabIndex = 6
Top = 570
Width = 405
End
Begin VB.Label Label5
AutoSize = -1 'True
BackColor = &H00808000&
Caption = "驱动器:"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Left = 210
TabIndex = 7
Top = 2130
Width = 585
End
End
Attribute VB_Name = "fmFname"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*********************************************************************
' Fname.frm 选择仪器存储文件区和PC文件名
'*********************************************************************
Public sDir As String
Const FILEFLAG = 1
Const DIRFLAG = 2
Const TEXTFLAG = 3
Dim SelectFlag As Integer
'确认
Sub Command1_Click()
On Error GoTo ErrorTrap
If SelectFlag = TEXTFLAG Then
If FullPath <> "" And Combo1.Enabled Then
If Combo1.Text = "" Then
MsgBox "请输入仪器存储文件号"
Exit Sub
End If
FullPath = FullPath & Text1.Text & Combo1.Text & ".SIR"
On Error GoTo 0
ExitForm
ElseIf FullPath <> "" And Not Combo1.Enabled Then
FullPath = FullPath & Text1.Text
Combo1.Enabled = True
On Error GoTo 0
ExitForm
End If
ElseIf SelectFlag = DIRFLAG Then
Dir1.path = Dir1.List(Dir1.ListIndex)
Dir1_Change
If Text1.Text <> "" Then
If Right$(Dir1.path, 1) = "\" Then
FullPath.Text = Dir1.path + Text1.Text & Combo1.Text '& ".SIR"
Else
FullPath.Text = Dir1.path + "\" + Text1.Text & Combo1.Text '& ".SIR"
End If
ExitForm
Else
MsgBox "请输入文件名"
End If
End If
Exit Sub
ErrorTrap:
Beep
Resume Next
End Sub
'取消
Sub Command2_Click()
FullPath = ""
ExitForm
End Sub
Sub Dir1_Change()
FillLabel1
Drive1.Drive = Dir1.path
SelectFlag = DIRFLAG
End Sub
Sub Dir1_Click()
' SelectFlag = DIRFLAG
End Sub
Sub Drive1_Change()
Dir1.path = Drive1.Drive
' SelectFlag = DIRFLAG
End Sub
Sub ExitForm()
fmFname.Hide
End Sub
Sub FillLabel1()
Label1.Caption = Dir1.path
If Label1.width > 2200 Then
a$ = Left$(Dir1.path, 3)
b$ = Mid$(Dir1.path, 4)
Do While InStr(b$, "\")
b$ = Mid$(b$, InStr(b$, "\") + 1)
Loop
End If
End Sub
Sub Form_Activate()
FullPath = ""
If FullPath.Text = "" Then
FullPath.Text = Dir1.path + "\"
End If
SelectFlag = DIRFLAG
End Sub
Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
If Shift = 4 Then
Select Case KeyCode
Case 78: 'Alt+N
Text1.SetFocus
Case 68: 'Alt+D
Dir1.SetFocus
Case 84 'Alt+T
FileTypes.SetFocus
Case 86 'Alt+V
Drive1.SetFocus
End Select
End If
End Sub
Sub Form_Load()
fmFname.Left = (Screen.width - fmFname.width) / 2
fmFname.Top = (Screen.Height - fmFname.Height) / 2
Combo1.Clear
Dir1.path = sDir
End Sub
Function GetFileType$()
tmp$ = FileTypes.Text
p1 = InStr(tmp$, "(") + 1
p2 = InStr(tmp$, ")")
If p1 > 0 And p2 > p1 Then
GetFileType$ = LCase$(Mid$(tmp$, p1, p2 - p1))
Else
GetFileType$ = "*.*"
End If
End Function
Sub Text1_Change()
' SelectFlag = TEXTFLAG
End Sub