frmaddtodb.frm

几个不错的VB例子

         Caption         =   " Categories"
         ForeColor       =   &H00000000&
         Height          =   240
         Left            =   45
         TabIndex        =   40
         Top             =   3945
         Width           =   3930
      End
   End
   Begin VB.Data DataPictures 
      Caption         =   "DataPictures"
      Connect         =   "Access"
      DatabaseName    =   ""
      DefaultCursorType=   0  'DefaultCursor
      DefaultType     =   2  'UseODBC
      Exclusive       =   0   'False
      Height          =   345
      Left            =   2640
      Options         =   0
      ReadOnly        =   0   'False
      RecordsetType   =   1  'Dynaset
      RecordSource    =   ""
      Top             =   7515
      Visible         =   0   'False
      Width           =   2910
   End
End
Attribute VB_Name = "frmAddtoDB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' ==================
'    Thumb DB 1.5
' ==================
' Carles P.V. - 2001
' [e-mail]
' ==================

Option Explicit





Private FilePath As String      'Full file path string
Private Saving_to_DB As Boolean 'Adding thumbnails
Private Cancel_Save As Boolean  'Cancel button flag
Private IDCat As String         'Category ID



Private Sub Form_Activate()
    
    '## Get ID
    With TreeView.SelectedItem
        lblSelectedCat = " " & .Text
        IDCat = Right(.Key, Len(.Key) - 1)
    End With
    
End Sub

Private Sub Form_Load()
    
    '## Fill TreeView with detected drives
    Detect_Drives Dir
    
    '## Set Paths
    Dir_back.Path = Left(UCase(App.Path), 3)
    File_back.Path = Dir_back.Path
    
    '## Select actual path (app)
    Dir.Nodes(Left(UCase(Dir_back.Path), 3)).Selected = True
    Dir.SelectedItem.Key = Dir_back.Path
    
    '## Scan folders and fill file list
    ScanFolders (Dir_back.Path)
    Dir.Nodes(Dir_back.Path).Selected = True
    Dir.SelectedItem.Expanded = True
    ScanFiles
    
    '## Reset saving to DB flag
    Saving_to_DB = False
        
    '## Draw decorative bars
    DrawBar Me, 0
    DrawBar Me, 27
    DrawBar Me, 460

End Sub

' =================================================================================
' TOOLBAR: Add selected/all pictures / Exit form
' =================================================================================

Private Sub Commands_ButtonClick(ByVal Button As MSComctlLib.Button)
    
    '## Check if category is selected
    If (Button.Index <= 2) And IDCat = "" Then
        MsgBox "Select a category", vbInformation, "Add pictures"
        Exit Sub
    End If
    
    '## Reset cancel button flag and deactivate all
    Cancel_Save = False
    Me_back.Enabled = False
    Me_back2.Enabled = False
    Me_back3.Enabled = False
    
    '## Reset progress bar
    shpPerc.Width = 0
    lblPerc = "0%"
    
    Select Case Button.Key
        
    '## Add selected pictures
        Case "Add_Sel"
                    
            Dim NSel As Integer
            Dim FSel As Integer
            Dim CSel As Integer
            
            '# Get selected files
            For I = 0 To File.ListCount - 1
                If File.Selected(I) = True Then
                   If FSel = 0 And NSel = 0 Then FSel = I
                   NSel = NSel + 1
                End If
            Next I
            
            '# Check if exceeds 500 thumbnails
            If GetThumbsNumber(IDCat) + NSel > 500 Then
            
                MsgBox "The number of thumbnails you are going to add" & NL & _
                       "exceeds maximum allowed (500 thumbnails per category)" & NL & NL & _
                       "Change your selection or create another category", _
                       vbExclamation, _
                       "Maximum exceeded"
                    
                '# Reactivate all
                Cancel_Save = True
                Me_back.Enabled = True
                Me_back2.Enabled = True
                Me_back3.Enabled = True
    
                Exit Sub
                 
            End If
            
            Saving_to_DB = True
            Cancel_Process.Enabled = True
            
            '# If first item to add isn't actual selected, select it
            If NSel > 0 Then
                If File.ListIndex = FSel Then File_Click
                If File.ListIndex <> FSel Then File.ListIndex = FSel
            End If
                            
                '# Start timing
                t = GetTickCount
                
                For I = FSel To File.ListCount - 1
                    
                    '# Check if cancel button has been pressed
                    DoEvents
                    If Cancel_Save = True Then Exit For
                    
                    If File.Selected(I) = True Then
                        
                        '# If item selected, make thumbnail and save to DB
                        File.ListIndex = I
                        Save_to_DB
                        
                        '# Refresh progress bar
                        shpPerc.Width = ((CSel + 1) / NSel) * 292 * 15
                        lblPerc = Int((CSel + 1) / NSel * 100) & "%"
                        
                        '# Refresh timing
                        lblTime = Format((GetTickCount - t) / 1000, "0.00 s.")
                        lblTime.Refresh
                        
                        '# Selected item counter
                        CSel = CSel + 1
                        
                    End If
                Next I
                
            Saving_to_DB = False
            lblThumbs = Format(GetThumbsNumber(IDCat), "000") & "/500"
            
    '## Add all pictures
        Case "Add_All"
        
            '# Check if exceeds 500 thumbnails
            If GetThumbsNumber(IDCat) + File.ListCount > 500 Then
            
                MsgBox "The number of thumbnails you are going to add" & NL & _
                       "exceeds maximum allowed (500 thumbnails per category)" & NL & NL & _
                       "Change your selection or create another category", _
                       vbExclamation, _
                       "Maximum exceeded"
                    
                '# Reactivate all
                Cancel_Save = True
                Me_back.Enabled = True
                Me_back2.Enabled = True
                Me_back3.Enabled = True
                
                Exit Sub
                 
            End If
        
            Saving_to_DB = True
            Cancel_Process.Enabled = True
            
            '# If first item to add isn't actual selected, select it
            If File.ListIndex = 0 Then File_Click
            If File.ListIndex <> 0 Then File.ListIndex = 0
                
                '# Start timing
                t = GetTickCount
                
                For I = 0 To File.ListCount - 1
                
                    '# Check if cancel button has been pressed
                    DoEvents
                    If Cancel_Save = True Then Exit For
                    
                    '# Make thumbnail and save to DB
                    File.ListIndex = I
                    Save_to_DB
                    
                    '# Refresh progress bar
                    shpPerc.Width = ((I + 1) / File_back.ListCount) * 292 * 15
                    lblPerc = Int((I + 1) / File_back.ListCount * 100) & "%"
                    
                    '# Refresh timing
                    lblTime = Format((GetTickCount - t) / 1000, "0.00 s.")
                    lblTime.Refresh
                    
                Next I
                
            Saving_to_DB = False
            lblThumbs = Format(GetThumbsNumber(IDCat), "000") & "/500"
            
    '## Exit form
        Case "Exit"
        
            Me.Hide
            frmView.Hide
            frmMain.Enabled = True
    
    End Select
    
    '## Disables cancel button and reactivate all
    Cancel_Process.Enabled = False
    Me_back.Enabled = True
    Me_back2.Enabled = True
    Me_back3.Enabled = True
    
End Sub

' =================================================================================
' TREEVIEW: Select category
' =================================================================================

Private Sub btnExpandC_Click()
    
    TreeView.Visible = False
    
    For I = 1 To TreeView.Nodes.Count
        TreeView.Nodes(I).Expanded = True
    Next I
    TreeView.SelectedItem.EnsureVisible

    TreeView.Visible = True
    TreeView.SetFocus

End Sub

Private Sub btnContractC_Click()

    For I = 1 To TreeView.Nodes.Count
        TreeView.Nodes(I).Expanded = False
    Next I
    
    lblSelectedCat = " " & TreeView.Nodes(1)
    lblThumbs = ""
    TreeView.SetFocus
    
End Sub

Private Sub Treeview_NodeClick(ByVal Node As MSComctlLib.Node)

    '## Select category to add thumbnails...
    
    With Node
        '# Get number ID part
        IDCat = Right(.Key, Len(.Key) - 1)
        '# Refresh category label
        lblSelectedCat = " " & .Text
        '# Refresh # of thumbnails label
        If IDCat = "" Then
            lblThumbs = ""
        Else
            lblThumbs = Format(GetThumbsNumber(IDCat), "000") & "/500"
        End If
    End With

End Sub

' =================================================================================
' TREEVIEW: Folders & picture files control (File search)
' =================================================================================

Private Sub btnExpandF_Click()
    
    Dir.Visible = False
    
    For I = 1 To Dir.Nodes.Count
        Dir.Nodes(I).Expanded = True
    Next I
    Dir.SelectedItem.EnsureVisible
    
    Dir.Visible = True
    Dir.SetFocus

End Sub

Private Sub btnContractF_Click()

    For I = 1 To Dir.Nodes.Count
        Dir.Nodes(I).Expanded = False
    Next I
    
    '## Set Paths
    Dir_back.Path = Left(UCase(App.Path), 3)
    File_back.Path = Dir_back.Path
    
    '## Select actual path (app)
    Dir.Nodes(Left(UCase(Dir_back.Path), 3)).Selected = True
    Dir.SelectedItem.Key = Dir_back.Path
    
    '## Fill file list
    Dir.Nodes(Dir_back.Path).Selected = True
    ScanFiles
    Dir.SetFocus
    
End Sub

Private Sub Dir_NodeClick(ByVal Node As MSComctlLib.Node)

    '## Change to selected dir/drive
    On Error Resume Next
    ChDir Dir.SelectedItem.Key
    
    If Err.Number = 75 Then
        
        '# Drive not ready
        MsgBox Left(UCase(Dir.SelectedItem.Key), 2) & " access error" & NL & NL & _
               "Drive not ready", vbCritical, ""
        
        Err.Clear
        Exit Sub
        
    End If
        
    '## Refresh back dir/file
    Dir_back.Path = Dir.SelectedItem.Key
    File_back.Path = Dir_back.Path
    
    '## Refresh file list
    ScanFiles
    '## Scan subfolders
    If Node.Children = False Then ScanFolders (Dir_back.Path): Node.Expanded = True
   
End Sub

Private Sub File_Click()
    
    '## Show Thumbnail
    If File.ListIndex <> -1 Then Get_Thumbnail
     
End Sub

Private Sub ScanFolders(NodeTemp As String)

    Dim NodeX As Node
    Dim FolderName As String
    Dim tmpDir As String
    
    tmpDir = Dir_back.List(Dir_back.ListIndex)