frmmain.frm

vb源码大全

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "简易文件管理器"
   ClientHeight    =   3270
   ClientLeft      =   150
   ClientTop       =   720
   ClientWidth     =   4575
   LinkTopic       =   "Form4"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3270
   ScaleWidth      =   4575
   StartUpPosition =   3  '窗口缺省
   Begin VB.ComboBox cboFilter 
      Height          =   300
      Left            =   120
      TabIndex        =   6
      Text            =   "*.*"
      Top             =   2880
      Width           =   2055
   End
   Begin VB.DriveListBox drvList 
      Height          =   300
      Left            =   120
      TabIndex        =   4
      Top             =   360
      Width           =   2055
   End
   Begin VB.DirListBox dirList 
      Height          =   1770
      Left            =   120
      TabIndex        =   2
      Top             =   720
      Width           =   2055
   End
   Begin VB.FileListBox filList 
      Height          =   2790
      Left            =   2280
      TabIndex        =   1
      Top             =   360
      Width           =   2175
   End
   Begin VB.Label Label5 
      AutoSize        =   -1  'True
      Caption         =   "文件类型(&T)："
      Height          =   180
      Left            =   120
      TabIndex        =   5
      Top             =   2640
      Width           =   1170
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      Caption         =   "选择文件夹(&D)："
      Height          =   180
      Left            =   120
      TabIndex        =   3
      Top             =   120
      Width           =   1350
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "文件列表(&F)："
      Height          =   180
      Left            =   2280
      TabIndex        =   0
      Top             =   120
      Width           =   1170
   End
   Begin VB.Menu mnuDir 
      Caption         =   "文件夹(&D)"
      Begin VB.Menu mnuDirNew 
         Caption         =   "新建(&N)..."
         Shortcut        =   ^N
      End
      Begin VB.Menu mnuDirDel 
         Caption         =   "删除(&D)"
      End
      Begin VB.Menu mnuBar3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuDirRename 
         Caption         =   "重命名(&R)..."
      End
      Begin VB.Menu mnuDirAttribute 
         Caption         =   "属性(&P)..."
      End
      Begin VB.Menu mnuBar2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "退出(&X)"
         Shortcut        =   ^X
      End
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件(&F)"
      Begin VB.Menu mnuFileRename 
         Caption         =   "重命名(&R)..."
         Shortcut        =   {F2}
      End
      Begin VB.Menu mnuFileAttribute 
         Caption         =   "属性(&A)..."
         Shortcut        =   {F4}
      End
      Begin VB.Menu mnuBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileCopy 
         Caption         =   "复制(&C)"
      End
      Begin VB.Menu mnuFilePaste 
         Caption         =   "粘贴(&P)"
      End
      Begin VB.Menu mnuFileDel 
         Caption         =   "删除(&D)"
         Shortcut        =   {DEL}
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim msFileToCopy  '所拷贝的文件的名称
Dim msPathToCopy  '所拷贝的文件的路径

Private Sub dirList_Change()
    filList.Path = dirList.Path
End Sub

Private Sub drvList_Change()
   dirList.Path = drvList.Drive
End Sub

Private Sub cboFilter_Change()
   filList.Pattern = cboFilter.Text
End Sub

Private Sub cboFilter_Click()
   filList.Pattern = cboFilter.Text
End Sub

Private Sub filList_DblClick()
   mnuFileAttribute_Click
End Sub

Private Sub Form_Load()
    '添加文件类型
    cboFilter.AddItem "*.*"
    cboFilter.AddItem "*.doc"
    cboFilter.AddItem "*.txt"
    
    '设置在运行时显示在 FileListBox 中的文件类型
    filList.Pattern = "*.*"
    filList.Archive = True
    filList.Hidden = True
    filList.System = True
    filList.ReadOnly = True
    filList.Normal = True
    
    mnuFilePaste.Enabled = False
End Sub

Private Sub mnuDirAttribute_Click()
   If dirList.Path = "" Then Exit Sub
      
   Load frmAttribute
   frmAttribute.FileName = dirList.Path
   '以模式方式显示属性窗体
   frmAttribute.Show 1
   '文件列表更新，若为文件设置了隐藏属性，则自动隐藏文件
   filList.Refresh
End Sub

Private Sub mnuDirDel_Click()
   On Error GoTo errHandler
   If dirList.Path = "" Or Right(dirList.Path, 1) = "\" Then Exit Sub
   
   '询问是否要删除文件夹
   If MsgBox("真的要删除文件夹吗？", vbYesNo + vbDefaultButton2 + vbQuestion, "询问") = vbNo Then
     Exit Sub
   End If
    
   Dim strPath As String
   Dim n As Integer
   n = InStrRev(dirList.Path, "\")
   '取得所要删除的文件夹所在的路径,存入到strPath
   strPath = Left(dirList.Path, n - 1)
   
   '在删除某些某些隐藏的文件夹时，可能会出错，所以需要先改变文件夹的属性
   Dim nFileAttr As Integer
   nFileAttr = GetAttr(dirList.Path)
   Call SetAttr(dirList.Path, vbNormal)
   
   RmDir dirList.Path   '调用RmDir语句进行删除操作
   dirList.Path = strPath    '更新目录列表
   
   Exit Sub
   
errHandler:
   MsgBox Err.Description, vbCritical, "错误"
   '恢复文件夹的属性，注意使用SetAttr方法时，不能够设置vbDirectory值
   nFileAttr = nFileAttr - vbDirectory
   Call SetAttr(dirList.Path, nFileAttr)
End Sub

Private Sub mnuDirRename_Click()
   Dim strPath As String
   Dim strDir As String
   If dirList.Path = "" Or Right(dirList.Path, 1) = "\" Then Exit Sub
      
   Dim n As Integer
   n = InStrRev(dirList.Path, "\")
   '取得所要更改的文件夹的名称，以及该文件夹所在的路径
   strPath = Left(dirList.Path, n - 1)
   strDir = Right(dirList.Path, Len(dirList.Path) - n)
   
'   dirList.Path = strPath
   '调用Rename函数更改文件夹的名称，并来返回更改之后的文件夹的名称
   Dim strAfterDir As String
   strAfterDir = Rename(strPath, strDir)
   '根据Rename的返回值，重新设置dirList的路径
   If strAfterDir <> "" Then
      dirList.Path = strAfterDir
   End If
End Sub

Private Sub mnuFileDel_Click()

    On Error GoTo errHandler
    If filList.FileName = "" Then Exit Sub
    
    '询问是否要删除文件
    If MsgBox("真的要删除文件吗？", vbYesNo + vbDefaultButton2 + vbQuestion, "询问") = vbNo Then
      Exit Sub
    End If
    
    '扩展文件名为全路径名称
    Dim str As String
    str = filList.FileName
    If Right(filList.Path, 1) = "\" Then
      str = filList.Path & str
    Else
      str = filList.Path & "\" & str
    End If
    
    '在删除某些某些隐藏文件时，可能会出现文件没找到的错误
    '所以需要先改变文件的属性
    Dim nFileAttr As Integer
    nFileAttr = GetAttr(str)
    Call SetAttr(str, vbNormal)
   
    Kill str '使用Kill方法来删除文件
    filList.Refresh   '更新文件列表
    
    Exit Sub
errHandler:
   MsgBox Err.Description, vbCritical, "删除文件时，出现下列错误："
   '如果删除出错，就恢复文件的属性
   SetAttr str, nFileAttr
End Sub

Private Sub mnuExit_Click()
    Unload Me
End Sub

Private Sub mnuFileCopy_Click()
   '获取所要拷贝的文件名
    msFileToCopy = filList.FileName
    msPathToCopy = filList.Path
    
    mnuFilePaste.Enabled = (msFileToCopy <> "")
End Sub

Private Sub mnuFilePaste_Click()
    On Error GoTo errHandler
    
    '取得源文件的全路径名称
    Dim strCopyFrom As String
    strCopyFrom = msFileToCopy
    If Right(msPathToCopy, 1) = "\" Then
      strCopyFrom = msPathToCopy & strCopyFrom
    Else
      strCopyFrom = msPathToCopy & "\" & strCopyFrom
    End If
    '取得目标文件的全路径名称
    Dim strCopyTo As String
    strCopyTo = msFileToCopy
    If Right(dirList.Path, 1) = "\" Then
      strCopyTo = dirList.Path & strCopyTo
    Else
      strCopyTo = dirList.Path & "\" & strCopyTo
    End If
         
    '使用FileCopy语句来拷贝文件
    FileCopy strCopyFrom, strCopyTo
    filList.Refresh '刷新文件列表
    Exit Sub
    
errHandler:
    MsgBox Err.Description, vbCritical, "错误"
End Sub

Private Sub mnuDirNew_Click()
    On Error GoTo errHandler
        
    ChDir dirList.Path '设置到当前路径
    Dim str As String
    '取得文件夹的名称
    str = InputBox("输入所要创建的文件夹的名称！", "新建文件夹")
    If str = "" Then Exit Sub
    MkDir str '创建文件夹
    
    dirList.Refresh '刷新文件夹列表
    Exit Sub
    
errHandler:
   MsgBox Err.Description, vbCritical, "创建文件夹错误"
End Sub

Private Sub mnuFileRename_Click()
   If filList.FileName = "" Then Exit Sub
   
   '调用Rename函数来更改文件的名称
   Call Rename(filList.Path, filList.FileName)
   filList.Refresh   '更新文件列表
End Sub


Private Sub mnuFileAttribute_Click()
   If filList.FileName = "" Then Exit Sub
    
   '取得文件的全路径名称
   Dim strFile As String
   If Right(filList.Path, 1) = "\" Then
      strFile = filList.Path & filList.FileName
   Else
      strFile = filList.Path & "\" & filList.FileName
   End If
      
   Load frmAttribute
   frmAttribute.FileName = strFile
   frmAttribute.Show 1 '以模式方式显示属性窗体
End Sub

'该函数用以重命名文件或者文件夹
Private Function Rename(strPath As String, strFileDir As String) As String
  On Error GoTo errHandler
 
   Rename = ""
   If strFileDir = "" Then
      MsgBox "请选择重命名的对象！", vbCritical, "错误"
      Exit Function
   End If
   If Right(strFileDir, 1) = "\" Then
      MsgBox "不能够对根目录进行重命名", vbCritical, "错误"
      Exit Function
   End If

   '取得新的文件或者文件夹的名称
   Dim str As String
   str = InputBox("请输入新的名称", "输入名称")
   If str = "" Then Exit Function
   
   '将文件名扩展为全路径的文件名
   Dim str1 As String
   If Right(strPath, 1) = "\" Then
      str1 = strPath & strFileDir
      str = strPath & str
   Else
      str1 = strPath & "\" & strFileDir
      str = strPath & "\" & str
   End If
   Name str1 As str '使用Name语句来改变文件或者文件夹的名称
   Rename = str   '返回更改之后的文件或者文件名
   
   Exit Function
    
errHandler:
   MsgBox Err.Description, vbCritical, "重命名时，出现下列错误："
End Function