📄 frmdirproperty.frm
字号:
VERSION 5.00
Begin VB.Form FrmDirProperty
AutoRedraw = -1 'True
BorderStyle = 1 'Fixed Single
Caption = "属性"
ClientHeight = 5175
ClientLeft = 45
ClientTop = 330
ClientWidth = 5490
HasDC = 0 'False
Icon = "FrmDirProperty.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5175
ScaleWidth = 5490
StartUpPosition = 2 'CenterScreen
Begin VB.PictureBox Pictemp
BorderStyle = 0 'None
Height = 495
Index = 2
Left = 0
Picture = "FrmDirProperty.frx":0442
ScaleHeight = 495
ScaleWidth = 495
TabIndex = 22
Top = 0
Visible = 0 'False
Width = 495
End
Begin VB.CommandButton Command1
Caption = "确定(&O)"
Height = 375
Left = 4200
TabIndex = 21
Top = 4680
Width = 1095
End
Begin VB.Frame Frame4
Height = 125
Left = 120
TabIndex = 20
Top = 4440
Width = 5445
End
Begin VB.Frame Frame3
Height = 125
Left = 120
TabIndex = 13
Top = 3120
Width = 5445
End
Begin VB.Frame Frame2
Height = 125
Left = 0
TabIndex = 10
Top = 2160
Width = 5445
End
Begin VB.Frame Frame1
Height = 125
Left = -120
TabIndex = 5
Top = 1560
Width = 5445
End
Begin VB.TextBox Text1
Height = 375
Left = 1320
TabIndex = 4
Top = 960
Width = 3735
End
Begin VB.PictureBox Pictemp
AutoRedraw = -1 'True
BorderStyle = 0 'None
Height = 495
Index = 0
Left = 360
ScaleHeight = 495
ScaleWidth = 495
TabIndex = 3
Top = 960
Width = 495
End
Begin VB.PictureBox Picture2
BorderStyle = 0 'None
Height = 135
Left = 0
Picture = "FrmDirProperty.frx":0884
ScaleHeight = 135
ScaleWidth = 7455
TabIndex = 1
Top = 600
Width = 7455
Begin VB.PictureBox Picture3
BorderStyle = 0 'None
Height = 135
Left = 1920
Picture = "FrmDirProperty.frx":20EA
ScaleHeight = 135
ScaleWidth = 5655
TabIndex = 2
Top = 0
Width = 5655
End
End
Begin VB.PictureBox Picture1
BorderStyle = 0 'None
Height = 615
Left = 0
Picture = "FrmDirProperty.frx":3914
ScaleHeight = 615
ScaleWidth = 5535
TabIndex = 0
Top = 0
Width = 5535
Begin VB.Timer Timer1
Interval = 50
Left = 0
Top = 0
End
End
Begin VB.Label Label14
Height = 255
Left = 1320
TabIndex = 19
Top = 4080
Width = 3735
End
Begin VB.Label Label13
Caption = "访问时间"
Height = 255
Left = 360
TabIndex = 18
Top = 4080
Width = 855
End
Begin VB.Label Label12
Height = 255
Left = 1320
TabIndex = 17
Top = 3720
Width = 3735
End
Begin VB.Label Label11
Caption = "修改时间"
Height = 255
Left = 360
TabIndex = 16
Top = 3720
Width = 855
End
Begin VB.Label Label10
Height = 255
Left = 1320
TabIndex = 15
Top = 3360
Width = 3735
End
Begin VB.Label Label9
Caption = "创建时间"
Height = 255
Left = 360
TabIndex = 14
Top = 3360
Width = 855
End
Begin VB.Label Label6
Height = 255
Left = 1320
TabIndex = 12
Top = 2760
Width = 3735
End
Begin VB.Label Label5
Caption = "大小"
Height = 255
Left = 360
TabIndex = 11
Top = 2760
Width = 855
End
Begin VB.Label Label4
Height = 255
Left = 1320
TabIndex = 9
Top = 2400
Width = 3735
End
Begin VB.Label Label3
Caption = "位置"
Height = 255
Left = 360
TabIndex = 8
Top = 2400
Width = 855
End
Begin VB.Label Label2
Height = 255
Left = 1320
TabIndex = 7
Top = 1800
Width = 3735
End
Begin VB.Label Label1
Caption = "文件类型"
Height = 255
Left = 360
TabIndex = 6
Top = 1800
Width = 855
End
End
Attribute VB_Name = "FrmDirProperty"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Timer1_Timer()
Picture3.Left = Picture3.Left + 50
If Picture3.Left > Picture2.Left + Picture2.Width Then
Picture3.Left = Picture2.Left - Picture3.Width
End If
End Sub
'##################################################################################################
'窗体初始化 pType为显示类型 0显示文件属性 1文件夹属性 pFullPath对象路径 pViewPath显示名称
'##################################################################################################
Public Sub FrmInit(pType As Integer, pFullPath As String, pViewPath As String)
On Error Resume Next
Dim fs As FileSystemObject
Dim fd As Folder
Dim fl As File
Set fs = CreateObject("Scripting.FileSystemObject")
If pType = 0 Then '文件
Set fl = fs.GetFile(pFullPath)
GetAppIcon fl.Name
Label2 = fl.Type
Label4 = pViewPath
Label6 = CStr(fl.Size) + "字节"
Label10 = Format(fl.DateCreated, "yyyy年mm月dd日 hh:mm:ss")
Label12 = Format(fl.DateLastModified, "yyyy年mm月dd日 hh:mm:ss")
Label14 = Format(fl.DateLastAccessed, "yyyy年mm月dd日 hh:mm:ss")
Text1 = fl.Name
Else
Set fd = fs.GetFolder(pFullPath)
PicTemp(0).Picture = PicTemp(2).Picture
Label2 = fd.Type
Label4 = pViewPath
Label6 = CStr(fd.Size) + "字节"
Label10 = Format(fd.DateCreated, "yyyy年mm月dd日 hh:mm:ss")
Label12 = Format(fd.DateLastModified, "yyyy年mm月dd日 hh:mm:ss")
Label14 = Format(fd.DateLastAccessed, "yyyy年mm月dd日 hh:mm:ss")
Text1 = fd.Name
End If
FrmDirProperty.Show 1
Exit Sub
Err:
End Sub
'#####################################################################################
'获取所选文件图标 p_File_Name指定的文件路径
'#####################################################################################
Public Function GetAppIcon(p_File_Name As String) As Boolean
On Error GoTo Err
Dim tStr As String
Dim tStr1 As String
Dim t As Long
Dim tPos As Integer
Dim tFlag As Boolean
Dim tIconNum As Integer
Dim Pictmp As PictureBox
Dim rIconKey As String
AddControl PicTemp(1)
Set Pictmp = PicTemp(1)
tStr1 = GetSysPath
If InStr(1, p_File_Name, ".") = 0 Then GoTo Err
tStr = Mid(p_File_Name, InStr(1, p_File_Name, "."))
rIconKey = Mid(tStr, 2)
If IconExist(rIconKey) = True Then GoTo SkipTo
If GetRegVal("software\classes\" + tStr, tStr) = False Then GoTo Err
If GetRegVal("software\classes\" + tStr + "\defaulticon", tStr) = False Then GoTo Err
tPos = InStr(1, tStr, ",")
tIconNum = ExtractIcon(App.hInstance, Mid(tStr, 1, tPos - 1), -1)
't = ExtractIcon(App.hInstance, Mid(tStr, 1, tPos - 1), tIconNum - 1)
t = ExtractIcon(App.hInstance, Mid(tStr, 1, tPos - 1), CInt(Mid(tStr, tPos + 1)))
If t <= 0 Then GoTo Err
'Picsmall.AutoRedraw = True
tFlag = DrawIcon(Pictmp.hdc, 0, 0, t)
'tFlag = DrawIconEx(Picsmall.hdc, 0, 0, t, 32, 32, 0, 0, 2)
SavePicture Pictmp.Image, App.Path + "\temp.ico"
PicTemp(0).Picture = LoadPicture(App.Path + "\temp.ico")
SkipTo:
RemoveControl PicTemp(1)
GetAppIcon = True
Exit Function
Err:
RemoveControl PicTemp(1)
GetAppIcon = False
End Function
'##################################################################################################
'添加控件
'##################################################################################################
Public Function AddControl(p_Control As Control) As Boolean
On Error GoTo Err
Load p_Control
p_Control.Visible = False
AddControl = True
Exit Function
Err:
End Function
'##################################################################################################
'删除控件
'##################################################################################################
Public Function RemoveControl(p_Control As Control) As Boolean
On Error GoTo Err
Unload p_Control
RemoveControl = True
Exit Function
Err:
End Function
'#####################################################################################
'判断ImgBig中的图标是否存在 pExtendName为图标名
'#####################################################################################
Public Function IconExist(pExtendName As String) As Boolean
On Error GoTo Err
Dim imgX As ListImage
Set imgX = FrmMain.ImgBig.ListImages.Item(pExtendName)
IconExist = True
Exit Function
Err:
IconExist = False
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -