frmlv.frm

vb做的看图系统

        Set xcrc = New clsCRC
        xcrc.Algorithm = CRC32
    End If
    Set fso = CreateObject("Scripting.FileSystemObject")
    Lv1.ListItems.Clear
    Set Lv1.Icons = ImgList1
    If fso.FolderExists(Path) Then
        Set F = fso.GetFolder(Path)
        Set fj = F.Files
        For Each f1 In fj
            If f1.Type = Type_JPEG Then
                i% = i% + 1
                Set itmx = Lv1.ListItems.Add(i, f1.Path, f1.Name, i)
                itmx.SubItems(1) = KBytes(f1.Size)
                itmx.SubItems(2) = f1.Type
                itmx.SubItems(3) = Format$(f1.DateLastModified, "yyyy/mm/dd h:m AM/PM")
                itmx.SubItems(4) = splitAttr(f1.Attributes)     '1-R 2-H 32-A
                If ChkCRC Then
                    xcrc.CalculateFile f1.Path
                    itmx.SubItems(5) = Hex$(xcrc.Value)
                End If
                itmx.Tag = f1.Size
            End If
        Next
        Set F = Nothing
        Set fj = Nothing
        Set f1 = Nothing
    End If
    Set fso = Nothing
    If ChkCRC Then Set xcrc = Nothing
    FrmMdi.sbStatusBar.Panels(3).Text = Lv1.ListItems.Count & " 个对象"
    FrmMdi.sbStatusBar.Panels(4).Text = SetBytes(GetDiskSpaceFree(Mid$(Path, 1, 2)))
End Sub

Public Function KBytes(Bytes) As String
    On Error GoTo KBerror
    If Bytes >= 1073741824 Then
        KBytes = Format$(Bytes / 1024, "#0,000,000") & " KB"
    ElseIf Bytes >= 1048576 Then
        KBytes = Format$(Bytes / 1024, "#0,000") & " KB"
    ElseIf Bytes >= 1024 Then
        KBytes = (Format$(Bytes / 1024, "#0") + 1) & " KB"
    ElseIf Bytes < 1024 Then
        KBytes = "1 KB"
    End If
    Exit Function
KBerror:
    KBytes = "0 Bytes"
End Function

Public Function SetBytes(Bytes) As String
    On Error GoTo SBerror
    If Bytes >= 1073741824 Then
        SetBytes = Format$(Bytes / 1024 / 1024 / 1024, "#0.00") & " GB"
    ElseIf Bytes >= 1048576 Then
        SetBytes = Format$(Bytes / 1024 / 1024, "#0.00") & " MB"
    ElseIf Bytes >= 1024 Then
        SetBytes = (Format$(Bytes / 1024, "#0.00") + 1) & " KB"
    ElseIf Bytes < 1024 Then
        SetBytes = Bytes
    End If
    Exit Function
SBerror:
    SetBytes = "0 Bytes"
End Function

Private Sub Lv1_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim i%
    If KeyCode = vbKeyDelete Then
        FrmMdi.OperDelete
    End If
    'Ctrl + a
    If KeyCode = 65 And Shift = 2 And Lv1.ListItems.Count Then
        For i% = 1 To Lv1.ListItems.Count
            Lv1.ListItems(i%).Selected = True
        Next i%
        FrmMdi.sbStatusBar.Panels(1).Text = ""
        FrmMdi.sbStatusBar.Panels(2).Text = ""
        FrmMdi.sbStatusBar.Panels(3).Text = Lv1.ListItems.Count & " 个对象"
    End If
    ' Ctrl + r
    If KeyCode = 82 And Shift = 2 And Lv1.ListItems.Count Then
        RefreshLv Me.Caption
    End If
End Sub

Private Sub Lv1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then PopupMenu FrmMdi.MnuListView
End Sub

Private Sub Lv1_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
    If Data.GetFormat(vbCFText) Then
        Effect = vbDropEffectMove And Effect
    Else
        Effect = vbDropEffectMove
    End If
End Sub

Private Sub Lv1_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
    Dim itmx As ListItem
    Dim i%
    Set itmx = Lv1.SelectedItem
    Data.SetData , vbCFFiles
    For Each itmx In Lv1.ListItems
        If itmx.Selected Then
            Data.Files.Add itmx.Key
        End If
    Next
End Sub

Private Sub Lv1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim fs, F
    Dim i%
    On Error Resume Next
    Set fs = CreateObject("Scripting.FileSystemObject")
    If Data.GetFormat(vbCFFiles) Then
        For i% = 1 To Data.Files.Count
            Set F = fs.GetFile(Data.Files(i%))
            DiskOps F.Path, Me.Caption & F.Name, F_CopySmart, 1
            Set F = Nothing
        Next i%
    End If
    RefreshLv Me.Caption
    Set fs = Nothing
End Sub

Function splitAttr(attr As Integer) As String     '1-R 2-H 32-A
    If attr < 1 Then splitAttr = "": Exit Function
    Select Case attr
        Case 1
        splitAttr = "R"
        Case 2
        splitAttr = "H"
        Case 3
        splitAttr = "RH"
        Case 32
        splitAttr = "A"
        Case 33
        splitAttr = "AR"
        Case 34
        splitAttr = "AH"
        Case 35
        splitAttr = "ARH"
    End Select
End Function

Private Sub PicTop_DblClick()
    If Me.WindowState <> 2 Then
        Me.WindowState = 2
    Else
        Me.WindowState = 0
    End If
End Sub

Private Sub PicTop_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then DragForm Me
End Sub

Private Sub TMcmdClose_Click()
    Unload Me
End Sub

Public Function GetDiskSpaceFree(ByVal strDrive As String) As Long
    Dim lRet As Long
    Dim lBytes As Long
    Dim lSect As Long
    Dim lClust As Long
    Dim lTot As Long
    On Error Resume Next
    GetDiskSpaceFree = -1
    If True Then 'GetDrive(strDrive, strDrive) Then
        lRet = GetDiskFreeSpace(strDrive, lSect, lBytes, lClust, lTot)
        If Err.Number = 0 Then
            If lRet <> 0 Then
                GetDiskSpaceFree = lBytes * lSect * lClust
                If Err.Number <> 0 Then
                    GetDiskSpaceFree = &H7FFFFFFF
                End If
            End If
        End If
    End If
    Err.Clear
End Function

Sub CreateThumbs(Path As String, Size As Integer)
    On Error Resume Next
    Dim ximg As cIMAGE
    Dim W%, H%
    Dim fso, F, fc, fj, f1
    Dim i%, j%
    Dim c%
    Dim uRect As RECT
    Dim hBrush As Long
    Me.scaleMode = 3
    PicThumb.Width = Size + 8
    PicThumb.Height = Size + 8
    Me.scaleMode = 1
    If Shadow Then hBrush = CreateSolidBrush(RGB(200, 200, 200))
    ImgList1.ListImages.Clear
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(Path) Then
        Set F = fso.GetFolder(Path)
        Set fj = F.Files
        Me.scaleMode = 3
        pb1.Max = F.Files.Count
        Image1.Visible = True
        For Each f1 In fj
            j% = j% + 1
            'If f1.Type = "ACDSee JPEG Image" Then
            If f1.Type = Type_JPEG Then
                i% = i% + 1
                Set ximg = New cIMAGE
                With PicThumb
                    .Cls
                    ximg.Thumbnail f1.Path, Size, Size
                    W = ximg.ImageWidth
                    H = ximg.ImageHeight
                    If Shadow Then
                        SetRect uRect, (.Width - W) / 2, (.Height - H) / 2, (.Width + W) / 2, (.Height + H) / 2
                        FillRect .hDC, uRect, hBrush
                    End If
                    ximg.PaintDC .hDC, (.Width - W) / 2 - 3, (.Height - H) / 2 - 3
                    ImgList1.ListImages.Add i%, f1.Path, .Image
                End With
                Set ximg = Nothing
            End If
            pb1.Value = j
            Image1.Width = pb1.Value / pb1.Max * (PicTop.ScaleWidth - (Image1.Left * 1.3))
        Next
        Image1.Visible = False
        Set F = Nothing
        Set fj = Nothing
        Set f1 = Nothing
        Me.scaleMode = 1
    End If
    Set fso = Nothing
End Sub

Sub TCreateThumbs(Path As String, Size As Integer)
    On Error Resume Next
    Dim ximg As cIMAGE
    Dim W%, H%
    Dim fso, F, fc, fj, f1
    Dim i%, j%
    Dim c%
    Dim pnts(2) As POINTAPI
    Me.scaleMode = 3
    PicThumb.Width = Size + 8
    PicThumb.Height = Size + 8
    Me.scaleMode = 1
    ImgList1.ListImages.Clear
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(Path) Then
        Set F = fso.GetFolder(Path)
        Set fj = F.Files
        Me.scaleMode = 3
        pb1.Max = F.Files.Count
        Image1.Visible = True
        For Each f1 In fj
            j% = j% + 1
            'If f1.Type = "ACDSee JPEG Image" Then
            If f1.Type = Type_JPEG Then
                i% = i% + 1
                Set ximg = New cIMAGE
                With PicThumb
                    .Cls
                    ximg.Thumbnail f1.Path, Size, Size
                    W = ximg.ImageWidth
                    H = ximg.ImageHeight
                    ximg.PaintDC .hDC, (.Width - W) / 2 - 3, (.Height - H) / 2 - 3
                    If Shadow = "True" Then
                        If H > W Then
                            For c% = 0 To 2
                                .Forecolor = RGB(220 - 20 * c%, 220 - 20 * c%, 220 - 20 * c%)
                                pnts(0).x = (.Width + W) / 2 - 3 + c%
                                pnts(0).y = (.Height - H) / 2
                                pnts(1).x = (.Width + W) / 2 - 3 + c%
                                pnts(1).y = (.Height + H) / 2
                                Polyline .hDC, pnts(0), 2
                                pnts(0).x = (.Width - W) / 2
                                pnts(0).y = .Height - 7 + c%
                                pnts(1).x = (.Width + W) / 2
                                pnts(1).y = .Height - 7 + c%
                                Polyline .hDC, pnts(0), 2
                            Next c%
                        Else
                            For c% = 0 To 2
                                .Forecolor = RGB(220 - 20 * c%, 220 - 20 * c%, 220 - 20 * c%)
                                pnts(0).x = .Width - 7 + c%
                                pnts(0).y = (.Height - H) / 2
                                pnts(1).x = .Width - 7 + c%
                                pnts(1).y = (.Height + H) / 2
                                Polyline .hDC, pnts(0), 2
                                pnts(0).x = (.Width - W) / 2
                                pnts(0).y = (.Height + H) / 2 - 3 + c%
                                pnts(1).x = (.Width + W) / 2
                                pnts(1).y = (.Height + H) / 2 - 3 + c%
                                Polyline .hDC, pnts(0), 2
                            Next c%
                        End If
                    End If
                    ImgList1.ListImages.Add i%, f1.Path, .Image
                End With
                Set ximg = Nothing
            End If
            pb1.Value = j
            Image1.Width = pb1.Value / pb1.Max * (PicTop.ScaleWidth - (Image1.Left * 1.3))
        Next
        Image1.Visible = False
        Set F = Nothing
        Set fj = Nothing
        Set f1 = Nothing
        Me.scaleMode = 1
    End If
    Set fso = Nothing
End Sub