fileview.frm

国防工业部VB高级编程源码

            Set nd = tvwFile.Nodes.Add("mycomp", 4, drv.path, drv.DriveLetter, intimgindex, intimgindex)

        End If
        nd.Key = nd.Key & "\"
        nd.Tag = 2
        
        '文件夹
        intimgindex = 6
        If drv.DriveType <> Removable Then
            If drv.IsReady Then
                '开始读取
                strParent = drv.path + "\"
                Set fldr = drv.RootFolder
                Set fldrs = fldr.SubFolders
                '有子文件夹
                  
                For Each fldr1 In fldrs
                    Set nd = tvwFile.Nodes.Add(strParent, 4, fldr1.path, fldr1.Name, intimgindex, intimgindex)
                    nd.Tag = 0
                    NextNode fldr1.path, fldr1
                Next
                

            End If
        End If
    Next

    
End Sub

Private Sub NextNode(Parent As String, ByVal folder As Scripting.folder)
    Dim nd As Node
    If folder.SubFolders.Count <> 0 Then
        Set fldrs = folder.SubFolders
        For Each fldr1 In fldrs
            Set nd = tvwFile.Nodes.Add(Parent, 4, fldr1.path, fldr1.Name, 6, 6)
            nd.Tag = 0
            '穷尽所有的子文件夹
            'NextNode fldr1.Path, fldr1
        Next
    End If
End Sub

Private Sub Form_Resize()
    PlayOut
End Sub

Private Sub PlayOut()
    Dim sngheight As Single
    '窗体布局
    If frmFile.WindowState <> 1 Then
    tvwFile.Left = 0
    sngheight = frmFile.ScaleHeight
    If clbForm.Visible Then
        sngheight = sngheight - clbForm.Height
        tvwFile.Top = clbForm.Height
    Else
        tvwFile.Top = 0
    End If
    If stbForm.Visible Then
        sngheight = sngheight - stbForm.Height
    End If
    tvwFile.Height = sngheight
    tvwFile.Width = m_sngtvwWidth
    
    lvwFile.Top = tvwFile.Top
    lvwFile.Left = tvwFile.Width
    lvwFile.Height = tvwFile.Height
    lvwFile.Width = frmFile.ScaleWidth - tvwFile.Width
    End If
End Sub







Private Sub ImageCombo1_Click()
    tvwFile_NodeClick tvwFile.Nodes(ImageCombo1.SelectedItem.Key)
    tvwFile.Nodes(ImageCombo1.SelectedItem.Key).Expanded = True
    tvwFile.Nodes(ImageCombo1.SelectedItem.Key).EnsureVisible
End Sub

Private Sub ImageCombo1_Dropdown()
    Dim cmbitem As ComboItem
    Dim nd As Node
    Dim fullPath As String
    Dim subPath() As String
    Dim rootPath As String
    Dim intlocal As Integer
    Dim k As Integer
    Dim i As Integer
    k = 0
    
    ReDim subPath(1) As String
    
    Set nd = tvwFile.SelectedItem
    fullPath = nd.Key
    
    intlocal = 1
    intlocal = InStr(intlocal, fullPath, "\", vbTextCompare)
        
    Do While intlocal > 0
        ReDim Preserve subPath(UBound(subPath) + 1)
        subPath(k) = Left(fullPath, intlocal - 1)
        k = k + 1
        intlocal = intlocal + 1
        intlocal = InStr(intlocal, fullPath, "\", vbTextCompare)
    Loop
    subPath(k) = fullPath
     
     ImageCombo1.ComboItems.Clear
     Set nd = tvwFile.Nodes("desktop")
     Set cmbitem = ImageCombo1.ComboItems.Add(1, nd.Key, nd.Text, nd.Image, , 0)
     cmbitem.Tag = nd.Tag
     Set nd = tvwFile.Nodes("mycomp")
     Set cmbitem = ImageCombo1.ComboItems.Add(2, nd.Key, nd.Text, nd.Image, , 1)
     cmbitem.Tag = nd.Tag
     
     i = 3
     '决定顺序
     For Each drv In fso.Drives
            Set cmbitem = ImageCombo1.ComboItems.Add(i, drv.DriveLetter + ":\", drv.DriveLetter, , , 2)
            cmbitem.Image = tvwFile.Nodes(drv.path + "\").Image
            cmbitem.Tag = tvwFile.Nodes(drv.path + "\").Tag
            i = i + 1
        If drv.path = subPath(0) Then
          
            For intlocal = 1 To k
                If subPath(intlocal) <> drv.path + "\" Then
                    Set nd = tvwFile.Nodes(subPath(intlocal))
                    Set cmbitem = ImageCombo1.ComboItems.Add(i, nd.Key, nd.Text, nd.Image, , 2 + intlocal)
                        cmbitem.Tag = nd.Tag
                    i = i + 1
                End If
            Next
        End If
     Next
     ImageCombo1.ComboItems(fullPath).Selected = True
        
        
End Sub

Private Sub lvwFile_AfterLabelEdit(Cancel As Integer, NewString As String)
    Dim strPath As String
    Dim strName As String
    Dim bOk As Boolean
    '检查是否为空
    bOk = False
    NewString = Trim(NewString)
    If Len(NewString) <> 0 Then
        If lvwFile.SelectedItem.Tag = 0 Then '若是驱动器
            Cancel = True '取消
        ElseIf lvwFile.SelectedItem.Tag = 1 Then '若是文件夹
        
            strPath = lvwFile.SelectedItem.Key
            strName = lvwFile.SelectedItem.Text
            If StrComp(UCase(strName), UCase(NewString)) <> 0 Then
                strPath = Left(strPath, Len(strPath) - Len(strName)) + NewString
                    
                If fso.FolderExists(strPath) Then
                    MsgBox "此文件夹已存在！", vbOKCancel + vbCritical, "警告"
                    Cancel = True
                Else
                    bOk = True
                    fso.GetFolder(lvwFile.SelectedItem.Key).Name = NewString
                    '注意这个顺序，不可以互换
                    tvwFile.Nodes(lvwFile.SelectedItem.Key).Text = NewString
                    tvwFile.Nodes(lvwFile.SelectedItem.Key).Key = strPath
                    lvwFile.SelectedItem.Key = strPath
                End If
            Else
                Cancel = True
            End If
        ElseIf lvwFile.SelectedItem.Tag = 2 Then '若是文件
            strPath = lvwFile.SelectedItem.Key
            strName = lvwFile.SelectedItem.Text
             If StrComp(UCase(strName), UCase(NewString)) <> 0 Then
                 strPath = Left(strPath, Len(strPath) - Len(strName)) + NewString
                If fso.FileExists(strPath) Then
                    MsgBox "此文件已存在！", vbOKCancel + vbCritical, "警告"
                    Cancel = True
                Else
                    bOk = True
                    fso.GetFile(lvwFile.SelectedItem.Key).Name = NewString
                     lvwFile.SelectedItem.Key = strPath
               End If
            Else
                Cancel = True
            End If
     
        End If
    Else
        Cancel = True
    End If
    
    If bOk = False Then
        '注意，这一句不可少
        lvwFile.SetFocus
        lvwFile.SelectedItem.Selected = True
        lvwFile.StartLabelEdit
    End If
End Sub



Private Sub lvwFile_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    lvwFile.SortKey = ColumnHeader.Index - 1
    lvwFile.Sorted = True
End Sub


Private Sub lvwFile_DragDrop(Source As Control, x As Single, y As Single)
    Set lvwFile.DropHighlight = Nothing
End Sub

Private Sub lvwFile_DragOver(Source As Control, x As Single, y As Single, State As Integer)
    Set lvwFile.DropHighlight = lvwFile.HitTest(x, y)

End Sub

Private Sub lvwFile_GotFocus()
    m_bFocus = False
End Sub

Private Sub lvwFile_ItemClick(ByVal Item As MSComctlLib.ListItem)
    Dim sngtmclk As Single
    
    sngtmclk = Timer
    If m_bFClk = False Then
        m_sngtmDClk = sngtmclk
        m_bFClk = True
    Else
        If (sngtmclk - m_sngtmDClk) < 1 Then
            m_bFClk = False
         '运行程序
          OpenItem Item
        Else
            m_sngtmDClk = sngtmclk
            m_bFClk = True
        End If
    End If
    If Item.Tag = 0 Then
        If fso.GetDrive(Item.Key).IsReady Then
                stbForm.Panels(2).Text = CStr(Format(fso.GetDrive(Item.Key).TotalSize / 1024 / 1024 / 1024, "####.###")) + "G (剩余空间："
                stbForm.Panels(2).Text = stbForm.Panels(2).Text + CStr(Format(fso.GetDrive(Item.Key).FreeSpace / 1024 / 1024 / 1024, "####.###")) + "G)"
            Else
                stbForm.Panels(2).Text = "设备未准备好！"
            End If
    ElseIf Item.Tag = 1 Then
        stbForm.Panels(2).Text = CStr(Format(fso.GetFolder(Item.Key).Size / 1024 / 1024, "#######.##")) + "M (剩余空间："
        stbForm.Panels(2).Text = stbForm.Panels(2).Text + CStr(Format(fso.GetDrive(fso.GetDriveName(Item.Key)).FreeSpace / 1024 / 1024, "########.##")) + "M)"
    Else
        stbForm.Panels(2).Text = CStr(Format(fso.GetFile(Item.Key).Size / 1024, "#######.##")) + "K (剩余空间："
        stbForm.Panels(2).Text = stbForm.Panels(2).Text + CStr(Format(fso.GetDrive(fso.GetDriveName(Item.Key)).FreeSpace / 1024 / 1024, "########.##")) + "M)"
    End If
    
    
End Sub
Sub OpenItem(ByVal itemKey As ListItem)
    Set Item = itemKey
            If Item.Tag = 2 Then
                
               Openfile itemKey.Key
            Else '展开文件夹或者驱动器
                If Item.Tag = 0 Then
                    Set nd = tvwFile.Nodes(Item.Key)
                Else
                    Set nd = tvwFile.Nodes(Item.Key)
                End If
                tvwFile_NodeClick nd
                tvwFile.Nodes(Item.Key).Selected = True
                tvwFile.Nodes(Item.Key).Expanded = True
            End If

End Sub
 
     

'打开文件
Private Sub Openfile(ByVal strFileName As String)
    Dim str As String
    str = LCase(Right(strFileName, 3))
    Select Case str
    Case "exe"
        WinExec strFileName, SW_SHOWNORMAL
    Case "com"
        WinExec strFileName, SW_SHOWNORMAL
    Case "bat"
        WinExec strFileName, SW_SHOWNORMAL
    Case "txt"
        WinExec "notepad " + strFileName, SW_SHOWNORMAL
    Case Else
        MsgBox "对不起，本程序未给此文件作相关打开链接！", vbInformation + vbOKOnly, "注意"
    End Select
End Sub

Private Sub lvwFile_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        lvwFile_ItemClick lvwFile.SelectedItem
        lvwFile_ItemClick lvwFile.SelectedItem
    ElseIf KeyCode = 8 Then
        mnuViewUp_Click
    End If
End Sub

Private Sub lvwFile_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If x < 150 And x >= 0 And m_bMove = False Then
        frmFile.MousePointer = 9
        m_bMove = True
       
    ElseIf Button = 0 Then
        frmFile.MousePointer = 0
        m_bMove = False
    End If
    
    If Button = 1 And m_bMove Then
        MouseMove x, 2
    End If

End Sub

Private Sub lvwFile_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If m_bMove And Button = 1 Then
        frmFile.MousePointer = 0
        m_bMove = False
    End If
    '弹出菜单
    If Button = 2 Then
        PopupMenu mnuPop
    End If
End Sub


Private Sub mnuEditCopy_Click()
    Dim nd As Node
    Dim litem As ListItem
    ReDim m_arrayflPath(1) As String
    ReDim m_arrayfldrPath(1) As String
    
    m_arrayflPath(0) = ""
    m_arrayfldrPath(0) = ""

    m_bCopy = True

    If m_bFocus Then
        '树
        For Each nd In tvwFile.Nodes
            If nd.Selected Then
                nd.Bold = True
                ReDim Preserve m_arrayfldrPath(UBound(m_arrayfldrPath) + 1)
                m_arrayfldrPath(UBound(m_arrayfldrPath) - 1) = nd.Key
            End If
        Next
    Else
        For Each litem In lvwFile.ListItems
            If litem.Selected Then
                litem.Bold = True
                If litem.Tag = 1 Then
                    ReDim Preserve m_arrayfldrPath(UBound(m_arrayfldrPath) + 1)
                    m_arrayfldrPath(UBound(m_arrayfldrPath) - 1) = litem.Key
                ElseIf litem.Tag = 2 Then
                    ReDim Preserve m_arrayflPath(UBound(m_arrayflPath) + 1)
                    m_arrayflPath(UBound(m_arrayflPath) - 1) = litem.Key
                End If
            End If
       Next
    End If
End Sub

Private Sub mnuEditCopypop_Click()
    mnuEditCopy_Click
End Sub

Private Sub mnuEditCut_Click()
    Dim nd As Node
    Dim litem As ListItem
    ReDim m_arrayflPath(1) As String
    ReDim m_arrayfldrPath(1) As String
    
    m_arrayflPath(0) = ""
    m_arrayfldrPath(0) = ""