www.pudn.com > 档案管理系统源码VB.zip > SelectFile.frm
VERSION 5.00
Begin VB.Form SelectFile
BorderStyle = 3 'Fixed Dialog
Caption = "选择图片文件"
ClientHeight = 4005
ClientLeft = 45
ClientTop = 615
ClientWidth = 8385
Icon = "SelectFile.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4005
ScaleWidth = 8385
ShowInTaskbar = 0 'False
Begin VB.PictureBox picUP
AutoSize = -1 'True
Height = 540
Left = -1305
Picture = "SelectFile.frx":27A2
ScaleHeight = 480
ScaleWidth = 480
TabIndex = 15
Top = 90
Visible = 0 'False
Width = 540
End
Begin VB.PictureBox picDown
AutoSize = -1 'True
Height = 540
Left = -585
Picture = "SelectFile.frx":2AAC
ScaleHeight = 480
ScaleWidth = 480
TabIndex = 14
Top = 90
Visible = 0 'False
Width = 540
End
Begin VB.CheckBox Check2
BackColor = &H00C0C0C0&
Caption = "自动大小"
Enabled = 0 'False
ForeColor = &H00404000&
Height = 240
Left = 1455
TabIndex = 8
Top = 3135
Width = 1065
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
BorderStyle = 0 'None
Height = 3645
Left = 5325
ScaleHeight = 3645
ScaleWidth = 2925
TabIndex = 10
Top = 195
Width = 2925
Begin VB.CommandButton Command3
Height = 285
Left = 2655
TabIndex = 13
Top = 3375
Visible = 0 'False
Width = 285
End
Begin VB.HScrollBar HScroll1
Height = 270
LargeChange = 1000
Left = -15
SmallChange = 100
TabIndex = 12
Top = 3375
Visible = 0 'False
Width = 2685
End
Begin VB.VScrollBar VScroll1
Height = 3405
LargeChange = 1000
Left = 2655
SmallChange = 100
TabIndex = 11
Top = -15
Visible = 0 'False
Width = 270
End
Begin VB.Image DisplayPicture
Height = 3600
Left = -15
MousePointer = 99 'Custom
Top = -15
Width = 2880
End
End
Begin VB.CheckBox Check1
Caption = "预览图片"
ForeColor = &H00404000&
Height = 300
Left = 195
TabIndex = 7
Top = 3105
Width = 1155
End
Begin VB.ComboBox SelectType
Height = 300
Left = 165
Style = 2 'Dropdown List
TabIndex = 2
Top = 3525
Width = 2340
End
Begin VB.FileListBox File1
Height = 1890
Left = 165
TabIndex = 1
Top = 1110
Width = 2340
End
Begin VB.CommandButton Command2
Cancel = -1 'True
Caption = "取消(&C)"
Height = 390
Left = 3420
TabIndex = 6
Top = 780
Width = 1380
End
Begin VB.CommandButton Command1
Caption = "确定(&O)"
Default = -1 'True
Enabled = 0 'False
Height = 390
Left = 3420
TabIndex = 5
Top = 330
Width = 1380
End
Begin VB.DriveListBox Drive1
Height = 300
Left = 2715
TabIndex = 3
Top = 3510
Width = 2235
End
Begin VB.DirListBox Dir1
Height = 1770
Left = 2715
TabIndex = 4
Top = 1575
Width = 2235
End
Begin VB.TextBox Text1
Height = 270
Left = 180
Locked = -1 'True
TabIndex = 0
Top = 705
Width = 2325
End
Begin VB.Line Line9
BorderColor = &H00808080&
X1 = 5310
X2 = 8250
Y1 = 180
Y2 = 180
End
Begin VB.Line Line8
BorderColor = &H00808080&
X1 = 5310
X2 = 5310
Y1 = 180
Y2 = 3840
End
Begin VB.Line Line7
BorderColor = &H00FFFFFF&
X1 = 8250
X2 = 8250
Y1 = 180
Y2 = 3855
End
Begin VB.Line Line6
BorderColor = &H00FFFFFF&
X1 = 5325
X2 = 8250
Y1 = 3840
Y2 = 3840
End
Begin VB.Line Line5
BorderColor = &H00FFFFFF&
Index = 1
X1 = 2490
X2 = 2490
Y1 = 195
Y2 = 585
End
Begin VB.Line Line5
BorderColor = &H00808080&
Index = 0
X1 = 180
X2 = 180
Y1 = 195
Y2 = 585
End
Begin VB.Line Line4
BorderColor = &H00FFFFFF&
Index = 1
X1 = 195
X2 = 2505
Y1 = 585
Y2 = 585
End
Begin VB.Line Line4
BorderColor = &H00808080&
Index = 0
X1 = 180
X2 = 2490
Y1 = 180
Y2 = 180
End
Begin VB.Line Line3
BorderColor = &H00E0E0E0&
Index = 2
X1 = 30
X2 = 30
Y1 = 30
Y2 = 3945
End
Begin VB.Line Line2
BorderColor = &H00808080&
Index = 2
X1 = 8340
X2 = 8340
Y1 = 45
Y2 = 3975
End
Begin VB.Line Line2
BorderColor = &H00808080&
Index = 0
X1 = 15
X2 = 15
Y1 = 15
Y2 = 3960
End
Begin VB.Line Line1
BorderColor = &H00808080&
Index = 0
X1 = 15
X2 = 8355
Y1 = 15
Y2 = 15
End
Begin VB.Line Line1
BorderColor = &H00E0E0E0&
Index = 1
X1 = 15
X2 = 8340
Y1 = 30
Y2 = 30
End
Begin VB.Line Line1
BorderColor = &H00E0E0E0&
Index = 2
X1 = 0
X2 = 8355
Y1 = 3975
Y2 = 3975
End
Begin VB.Line Line1
BorderColor = &H00808080&
Index = 3
X1 = 15
X2 = 8340
Y1 = 3960
Y2 = 3960
End
Begin VB.Line Line3
BorderColor = &H00E0E0E0&
Index = 0
X1 = 8355
X2 = 8355
Y1 = 30
Y2 = 3990
End
Begin VB.Line Line2
BorderColor = &H00808080&
Index = 1
X1 = 5220
X2 = 5220
Y1 = 30
Y2 = 3945
End
Begin VB.Line Line3
BorderColor = &H00E0E0E0&
Index = 1
X1 = 5235
X2 = 5235
Y1 = 30
Y2 = 3945
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "选定的文件名称及路径"
ForeColor = &H00800000&
Height = 180
Left = 435
TabIndex = 9
Top = 315
Width = 1800
End
Begin VB.Menu MenuEdit
Caption = "编辑"
Begin VB.Menu DelFile
Caption = "删除(&D)"
Shortcut = ^D
End
End
End
Attribute VB_Name = "SelectFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Sx As Long, Sy As Long, Mx As Long, My As Long, LB As Boolean
Private Sub Check1_Click()
If Check1.Value = 1 Then
SelectFile.Width = 8475
Else
SelectFile.Width = 5355
DisplayPicture.Picture = LoadPicture()
Exit Sub
End If
If Text1.Text <> "" Then
SelectFile.MousePointer = 11
On Error GoTo NOp
If Check2.Value = 1 Then
DisplayPicture.Stretch = False
Else
DisplayPicture.Height = 3645
DisplayPicture.Width = 2925
DisplayPicture.Stretch = True
End If
DisplayPicture.Picture = LoadPicture(Text1.Text)
'Large photo display
If Check2.Value = 1 Then
HScroll1.Value = 0
VScroll1.Value = 0
HScroll1.Max = DisplayPicture.Width - Picture1.Width + 280
VScroll1.Max = DisplayPicture.Height - Picture1.Height + 280
VScroll1.Visible = Picture1.Height < DisplayPicture.Height
HScroll1.Visible = Picture1.Width < DisplayPicture.Width
If HScroll1.Visible Or VScroll1.Visible Then
Command3.Visible = True
Else
Command3.Visible = False
End If
Else
VScroll1.Visible = False
HScroll1.Visible = False
Command3.Visible = False
End If
SelectFile.MousePointer = 0
End If
Exit Sub
NOp:
MsgBox "图片出错，不能浏览！", vbOKOnly + 16, "图片不能安装"
DisplayPicture.Picture = LoadPicture()
SelectFile.MousePointer = 0
Exit Sub
End Sub
Private Sub Check2_Click()
On Error Resume Next
If Check1.Value = 1 Then
If Check2.Value = 1 Then
DisplayPicture.Stretch = False
HScroll1.Value = 0
VScroll1.Value = 0
HScroll1.Max = DisplayPicture.Width - Picture1.Width + 280
VScroll1.Max = DisplayPicture.Height - Picture1.Height + 280
VScroll1.Visible = Picture1.Height < DisplayPicture.Height
HScroll1.Visible = Picture1.Width < DisplayPicture.Width
If HScroll1.Visible Or VScroll1.Visible Then
Command3.Visible = True
Else
Command3.Visible = False
End If
Else
DisplayPicture.Height = 3645
DisplayPicture.Width = 2925
DisplayPicture.Stretch = True
DisplayPicture.Move 0, 0
VScroll1.Visible = False
HScroll1.Visible = False
Command3.Visible = False
End If
End If
End Sub
Private Sub Command1_Click()
ConfigForm.CC(5).Text = Text1.Text
Unload Me
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Command3_Click()
If HScroll1.Value < HScroll1.Max - 100 Then
HScroll1.Value = HScroll1.Value + 100
End If
If VScroll1.Value < VScroll1.Max - 100 Then
VScroll1.Value = VScroll1.Value + 100
End If
End Sub
Private Sub DelFile_Click()
Dim DelOk As Integer
DelOk = MsgBox("真的要删除文件：(Y/N) " & Chr(10) & Chr(13) & Text1.Text, vbYesNo + 16, "删除文件")
If DelOk = 6 Then
On Error GoTo KillErr
Kill Text1.Text
Text1.Text = ""
If Check1.Value = 1 Then
DisplayPicture.Picture = LoadPicture()
End If
File1.Refresh
Else
Exit Sub
End If
Exit Sub
KillErr:
MsgBox "删除文件错误，文件被打开或共享", vbOKOnly + 16, "警告"
Exit Sub
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
Select Case SelectType.Text
Case "位图文件|*.BMP"
File1.Pattern = "*.bmp"
Case "压缩文件|*.JPG"
File1.Pattern = "*.jpg"
Case "GIF文件|*.GIF"
File1.Pattern = "*.gif"
Case "图标文件|*.ICO"
File1.Pattern = "*.ico"
Case "WMF|*.WMF"
File1.Pattern = "*.wmf"
Case "EMF|*.EMF"
File1.Pattern = "*.emf"
Case "RLE|*.RLE"
File1.Pattern = "*.rle"
End Select
Text1.Text = ""
End Sub
Private Sub DisplayPicture_DblClick()
If Command1.Enabled = True Then
Call Command1_Click
End If
End Sub
Private Sub DisplayPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
LB = True
Sx = X
Sy = Y
DisplayPicture.MouseIcon = picDown.Picture
End Sub
Private Sub DisplayPicture_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If HScroll1.Visible = True Or VScroll1.Visible = True Then
If LB = True Then
Mx = X
My = Y
If HScroll1.Value + (Mx - Sx) / 50 <= HScroll1.Max And HScroll1.Value + (Mx - Sx) / 50 > 0 Then
HScroll1.Value = HScroll1.Value + (Mx - Sx) / 50
End If
If VScroll1.Value + (My - Sy) / 50 <= VScroll1.Max And VScroll1.Value + (My - Sy) / 50 > 0 Then
VScroll1.Value = VScroll1.Value + (My - Sy) / 50
End If
End If
End If
If Text1.Text = "" Then
DisplayPicture.ToolTipText = "没有图片装载"
ElseIf Check2.Value = 1 Then
DisplayPicture.ToolTipText = "图片：宽 " & DisplayPicture.Width / 15 & " 点、高 " & DisplayPicture.Height / 15 & " 点"
Else
DisplayPicture.ToolTipText = "要想显示图片大小，选取自动大小！"
End If
End Sub
Private Sub DisplayPicture_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
LB = False
DisplayPicture.MouseIcon = picUP.Picture
End Sub
Private Sub Drive1_Change()
On Error GoTo Noread
Dir1.Path = Drive1.Drive
Text1.Text = ""
Exit Sub
Noread:
Dim Okread As Integer
Okread = MsgBox("" & Drive1.Drive & " 驱动器没有准备好！", vbRetryCancel + 16, "驱动器没有准备好！")
If Okread = 4 Then
Call Drive1_Change
Else
Drive1.Drive = Dir1.Path
Text1.Text = ""
End If
End Sub
Private Sub File1_Click()
Dim DirStr As String
DirStr = Dir1.Path
If Right(DirStr, 1) <> "\" Then
DirStr = DirStr + "\"
End If
DirStr = DirStr + File1.FileName
Text1.Text = DirStr
If Check1.Value = 1 Then
On Error GoTo PictureErr
SelectFile.MousePointer = 11
If Check2.Value = 1 Then
DisplayPicture.Stretch = False
Else
DisplayPicture.Height = 3645
DisplayPicture.Width = 2925
DisplayPicture.Stretch = True
End If
DisplayPicture.Picture = LoadPicture(Text1.Text)
'Large photo display
If Check2.Value = 1 Then
HScroll1.Value = 0
VScroll1.Value = 0
HScroll1.Max = DisplayPicture.Width - Picture1.Width + 280
VScroll1.Max = DisplayPicture.Height - Picture1.Height + 280
VScroll1.Visible = Picture1.Height < DisplayPicture.Height
HScroll1.Visible = Picture1.Width < DisplayPicture.Width
If HScroll1.Visible Or VScroll1.Visible Then
Command3.Visible = True
Else
Command3.Visible = False
End If
Else
VScroll1.Visible = False
HScroll1.Visible = False
Command3.Visible = False
End If
End If
SelectFile.MousePointer = 0
Exit Sub
PictureErr:
MsgBox "图片出错，不能浏览！", vbOKOnly + 16, "图片不能安装"
DisplayPicture.Picture = LoadPicture()
SelectFile.MousePointer = 0
Exit Sub
End Sub
Private Sub File1_DblClick()
Call Command1_Click
End Sub
Private Sub File1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
If File1.ListIndex >= 0 Then
DelFile.Enabled = True
Else
DelFile.Enabled = False
End If
PopupMenu MenuEdit
End If
End Sub
Private Sub Form_Load()
Me.Left = Val(GetSetting(App.EXEName, "SelectPhoto", "Left"))
Me.Top = Val(GetSetting(App.EXEName, "SelectPhoto", "Top"))
MenuEdit.Visible = False
SelectFile.Width = 5355
SelectType.AddItem "所有图片文件(*.*)", 0
SelectType.AddItem "位图文件|*.BMP", 1
SelectType.AddItem "压缩文件|*.JPG", 2
SelectType.AddItem "GIF文件|*.GIF", 3
SelectType.AddItem "图标文件|*.ICO", 4
SelectType.AddItem "WMF|*.WMF", 5
SelectType.AddItem "EMF|*.EMF", 6
SelectType.AddItem "RLE|*.RLE", 7
SelectType.ListIndex = 0
File1.Pattern = "*.bmp;*.jpg;*.gif;*.ico;*.wmf;*.emf;*.rle"
DisplayPicture.MousePointer = 99
DisplayPicture.MouseIcon = picUP.Picture
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveSetting App.EXEName, "SelectPhoto", "Left", Me.Left
SaveSetting App.EXEName, "SelectPhoto", "Top", Me.Top
End Sub
Private Sub HScroll1_Change()
DisplayPicture.Left = -HScroll1.Value
End Sub
Private Sub PastFile_Click()
End Sub
Private Sub SelectType_Click()
Text1.Text = ""
Select Case SelectType.Text
Case "所有图片文件(*.*)"
File1.Pattern = "*.bmp;*.jpg;*.gif;*.ico;*.wmf;*.emf;*.rle"
Case "位图文件|*.BMP"
File1.Pattern = "*.bmp"
Case "压缩文件|*.JPG"
File1.Pattern = "*.jpg"
Case "GIF文件|*.GIF"
File1.Pattern = "*.gif"
Case "图标文件|*.ICO"
File1.Pattern = "*.ico"
Case "WMF|*.WMF"
File1.Pattern = "*.wmf"
Case "EMF|*.EMF"
File1.Pattern = "*.emf"
Case "RLE|*.RLE"
File1.Pattern = "*.rle"
End Select
File1.Refresh
End Sub
Private Sub Text1_Change()
If Trim(Text1.Text) = "" Then
Command1.Enabled = False
DisplayPicture.Picture = LoadPicture()
Check2.Enabled = False
Else
Command1.Enabled = True
Check2.Enabled = True
End If
End Sub
Private Sub VScroll1_Change()
DisplayPicture.Top = -VScroll1.Value
End Sub