frmaddtodb.frm

几个不错的VB例子

    '## Scan all subfolders
    Screen.MousePointer = vbArrowHourglass
    
        For I = 0 To Dir_back.ListCount - 1
            
            '# Get folder name
            FolderName = Right(Dir_back.List(I), Len(Dir_back.List(I)) - InStrRev(Dir_back.List(I), "\", , 1))
            '# Add node
            Set NodeX = Dir.Nodes.Add(NodeTemp, tvwChild, Dir_back.List(I), FolderName)
            
            Dir_back = Dir_back.List(I)
            
                If Dir_back.ListCount > 0 Then
                    '# Subfolders in folder
                    NodeX.Image = 8
                    NodeX.SelectedImage = 10
                Else
                    '# Last folder
                    NodeX.Image = 7
                    NodeX.SelectedImage = 9
                End If
                
            '# Refresh back dir control
            Dir_back = tmpDir
            
        Next I
    
    Screen.MousePointer = vbDefault
    
End Sub

Private Sub ScanFiles()

    '## Set new file pattern
    Dim tmpExt As String
    
    For I = 0 To chkExt.Count - 1
        If chkExt(I).Value = 1 Then
            If chkFileNameFilter Then
                tmpExt = tmpExt & txtFileNameFilter & chkExt(I).Tag
            Else
                tmpExt = tmpExt & chkExt(I).Tag
            End If
        End If
    Next
      
    If tmpExt = "" Then
        '# No type selected... (One way)
        File_back.Pattern = "*.no_files"
    Else
        '# Refresh by pattern
        tmpExt = Left(tmpExt, Len(tmpExt) - 1)
        File_back.Pattern = tmpExt
    End If
    
    '## File files list
    Screen.MousePointer = vbArrowHourglass
        
        '## Clear thumbnail picture and picture's info
        Image_Thumbnail = LoadPicture()
        lblName = ""
        lblSize = ""
        lblWidth = ""
        lblHeight = ""
    
        Dim itmx As ListItem
        Dim FilePath As String
        Dim TotalKb As Long
        
        '## Clear file list and reset Kb counter
        File.Clear
        File.Visible = False
        TotalKb = 0
        
        For I = 0 To File_back.ListCount - 1
                
             '# Get path (be careful in root folder)
             FilePath = File_back.Path & _
                        IIf(Right(File_back.Path, 1) <> "\", "\", "") & _
                        File_back.List(I)
             
             '# Add file to list
             File.AddItem UCase(File_back.List(I))
             TotalKb = TotalKb + FileLen(FilePath)
             
        Next I
        
        '# Show info
        lblInfo = " Files: " & Format(File_back.ListCount, "#,#0") & _
                  ". Total size: " & Format(TotalKb / 1024, "#,#0 Kb")
        File.Visible = True
        
    Screen.MousePointer = vbDefault
    
End Sub

Private Sub btnRefresh_Click()

    '## Refresh file list
    ScanFiles
    
End Sub

' =================================================================================
' Change file pattern / Invert files selection
' =================================================================================

Private Sub chkExt_Click(Index As Integer)
    
    ScanFiles
    
End Sub

Private Sub chkFileNameFilter_Click()

    ScanFiles

End Sub

Private Sub txtFileNameFilter_Change()
    
    If chkFileNameFilter Then ScanFiles
    
End Sub

Private Sub btnInvertSelection_Click()

    If File.ListCount = 0 Then Exit Sub
    
    Dim tmpItem As Integer
    Dim tmpTopItem As Integer
    Dim tmpchkThumb As Integer
    
    Screen.MousePointer = vbArrowHourglass
        
        '## This let do it faster
        File.Visible = False
            
        '## Get temp ListIndex & TopIndex
        tmpItem = File.ListIndex
        tmpTopItem = File.TopIndex
        tmpchkThumb = chkThumb: chkThumb = 0
            
        '## Invert checked
        For I = 0 To File.ListCount - 1
            If File.Selected(I) = True Then File.Selected(I) = False Else File.Selected(I) = True
        Next I
            
        '## Restore ListIndex & TopIndex
        File.ListIndex = tmpItem
        File.TopIndex = tmpTopItem
        chkThumb = tmpchkThumb
        
        '## ...
        File.Visible = True
        
    Screen.MousePointer = vbDefault

End Sub

Private Sub chkThumb_Click()
    
    If Not chkThumb Then Image_Thumbnail = LoadPicture()
  
End Sub

' =================================================================================
' Get and resize picture to Thumbnail
' =================================================================================

Private Sub Get_Thumbnail()
    
    '## Don't get it if...
    If chkThumb = 0 And Saving_to_DB = False Then Exit Sub
    
    Screen.MousePointer = vbArrowHourglass
    Image_Thumbnail.Visible = False
            
        '## Get picture path
        FilePath = File_back.Path & _
                   IIf(Right(File_back.Path, 1) <> "\", "\", "") & _
                   File.List(File.ListIndex)
        
        On Error Resume Next
        
            iLoaded = LoadPicture(FilePath)
            
            If Err.Number > 0 Then
                
                Err.Clear
                '# Invalid picture or something is going wrong
                Resp = MsgBox("Error loading picture :" & NL & NL & _
                       File.List(File.ListIndex), vbOKCancel Or vbCritical, "Thumb DB")
                
                '# Cancel save
                Saving_to_DB = False
                Screen.MousePointer = vbDefault
                
                '# Nothing to do...
                If Resp = vbCancel Then
                    Cancel_Save = True
                End If
                
                Exit Sub
                
            End If
            
        '## Calculated thumbnail dimensions
        Dim relWH As Single
        Dim W As Integer
        Dim H As Integer
        
        W = iLoaded.Width
        H = iLoaded.Height
        
        If W > Thumb_max_size Or H > Thumb_max_size Then
            If W >= H Then
               '# Stretch to width:
               Image_Thumbnail.Width = Thumb_max_size
               Image_Thumbnail.Height = (H / W) * Thumb_max_size
            Else
               '# Stretch to height:
               Image_Thumbnail.Height = Thumb_max_size
               Image_Thumbnail.Width = (W / H) * Thumb_max_size
            End If
            '# Resize
            StretchBlt Image_Thumbnail.hdc, _
                       0, 0, _
                       Image_Thumbnail.Width, Image_Thumbnail.Height, _
                       iLoaded.hdc, _
                       0, 0, _
                       iLoaded.Width, iLoaded.Height, _
                       SRCCOPY
        Else
            '# No stretch
            Image_Thumbnail = iLoaded
        End If
        
        '## Draw thumbnail border (no icons/cursors)
        If UCase(Right(File.List(File.ListIndex), 3)) <> "ICO" And _
           UCase(Right(File.List(File.ListIndex), 3)) <> "CUR" Then
            Image_Thumbnail.Line (0, 0)-(Image_Thumbnail.Width - 1, Image_Thumbnail.Height - 1), , B
        End If
        
        '## Get final image (sized)
        Set Image_Thumbnail = Image_Thumbnail.Image
        
        '## Show properties
        lblName = File.List(File.ListIndex)
        lblSize = Format(FileLen(FilePath) \ 1024, "##,##0 Kb")
        lblWidth = Format(W, "##,##")
        lblHeight = Format(H, "##,##")
        
        '## Center thumbnail
        Image_Thumbnail.Left = 280 + (79 - Image_Thumbnail.Width) / 2
        Image_Thumbnail.Top = 378 + (79 - Image_Thumbnail.Height) / 2
            
    Image_Thumbnail.Visible = True
    Screen.MousePointer = vbDefault
    
    '## Refresh View
    If frmView.Visible Then
        Set frmView.View = iLoaded
        frmView.View.BestFit
    End If
    
End Sub

' =================================================================================
' Saving to DB
' =================================================================================

Private Sub Cancel_Process_Click()

    '## Stop adding process
    Cancel_Save = True
    Cancel_Process.Enabled = False

End Sub

Private Sub Save_to_DB()

    If Not Saving_to_DB Then Exit Sub

    With DataPictures
    
        .Recordset.AddNew
            
            '## Add to DB
            .Recordset("Path") = FilePath
            .Recordset("IDCat") = IDCat
            .Recordset("Properties") = lblSize & " <" & lblWidth & "x" & lblHeight & ">"
            .Recordset("DateInDB") = Now
            If UCase(Right(File.List(File.ListIndex), 3)) = "ICO" Or _
               UCase(Right(File.List(File.ListIndex), 3)) = "CUR" Then
                Image_DB = iLoaded.Image
            Else
                Image_DB = Image_Thumbnail
            End If
            If chkAddComment Then
                .Recordset("Comments") = File.List(File.ListIndex)
            Else
                .Recordset("Comments") = ""
            End If
            
        .Recordset.Update
        
    End With
    
End Sub

' =================================================================================
' Get number of thumbnails
' =================================================================================

Private Function GetThumbsNumber(IDCat As String) As Integer

    With DataPictures
    
        '## Get recordset
        .RecordSource = "Select * from tblPictures where [IDCat] = '" & IDCat & "'"
        .Refresh
        
        '## Fill recordset
        If .Recordset.RecordCount > 0 Then
           .Recordset.MoveFirst
           .Recordset.MoveLast
        End If
        
        '## Get number of entries
        GetThumbsNumber = .Recordset.RecordCount
        
        '## Close recordset and set default source
        .Recordset.Close
        .RecordSource = "Select * from tblPictures where [IDCat] = ''"
        .Refresh

    End With

End Function

' =================================================================================
' View full picture
' =================================================================================

Private Sub Image_Thumbnail_Click()

    If Image_Thumbnail = 0 Then Exit Sub
    
    '## Show full size picture
    Set frmView.View = iLoaded
    frmView.View.BestFit
    frmView.Show , Me
    
End Sub

' =================================================================================
' Add drives to TreeView
' =================================================================================

Sub Detect_Drives(dstTreeView As TreeView)

    Dim Dr As Drive
    Dim SDL As String
    Dim FSO As New FileSystemObject
    Dim NodeX As Node
    
        On Error Resume Next

        For Each Dr In FSO.Drives
        
           SDL = UCase(Dr.DriveLetter) & ":"
            
           If Dr.DriveType = Removable Then
                Set NodeX = dstTreeView.Nodes.Add(, , SDL & "\", SDL, "floppy", "floppy")
           ElseIf Dr.DriveType = CDRom Then
                Set NodeX = dstTreeView.Nodes.Add(, , SDL & "\", SDL, "cd", "cd")
           ElseIf Dr.DriveType = Fixed Then
                Set NodeX = dstTreeView.Nodes.Add(, , SDL & "\", SDL, "fixed", "fixed")
           ElseIf Dr.DriveType = Remote Then
                Set NodeX = dstTreeView.Nodes.Add(, , SDL & "\", SDL, "remote", "remote")
           Else
                Set NodeX = dstTreeView.Nodes.Add(, , SDL & "\", SDL, "unknown", "unknown")
           End If
           
        Next Dr
        
        Set FSO = Nothing
        
End Sub