frmaddtodb.frm

管理电子相片 可以进行上传 评价 浏览 等操作

         ForeColor       =   &H00000000&
         Height          =   240
         Left            =   4125
         TabIndex        =   45
         Top             =   0
         Width           =   3930
      End
      Begin VB.Label lblSelectedCatBar 
         Appearance      =   0  'Flat
         BackColor       =   &H0000C000&
         BorderStyle     =   1  'Fixed Single
         Caption         =   "被选择的目录:"
         BeginProperty Font 
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   240
         Left            =   4125
         TabIndex        =   42
         Top             =   3405
         Width           =   3930
      End
   End
   Begin VB.Data DataPictures 
      Caption         =   "DataPictures"
      Connect         =   "Access"
      DatabaseName    =   ""
      DefaultCursorType=   0  '缺省游标
      DefaultType     =   2  '使用 ODBC
      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

Option Explicit

Private FSO          As New FileSystemObject

Private FilePath     As String  '-- 设置私有变量FilePath，数据类型为字符串，用来存放文件路径
Private Saving_to_DB As Boolean '-- 设置私有变量Saving_to_DB，数据类型为布尔值，设置是否保存到数据库
Private Cancel_Save  As Boolean '-- 设置私有变量Cancel_Save，数据类型为布尔值，取消按钮标志
Private IDCat        As String  '-- 设置私有变量IDCat，数据类型为布尔值，用来放置文件夹编号

Private LastIndex As Long       '-- 设置私有变量LastIndex，数据类型为长整型，用来最后选择的文件



Private Sub Form_Activate()
    '-- 获得文件夹编号
    With TreeView.SelectedItem
        lblSelectedCat = " " & .Text
        IDCat = Right$(.Key, Len(.Key) - 1)
    End With
End Sub

Private Sub Form_Load()
    '-- 在树型结构中放置所有的硬盘驱动器
    DirRefresh
    Saving_to_DB = False
End Sub

Private Sub Form_Paint()
    '-- 绘制装饰线
    DrawBar Me, 0
    DrawBar Me, 27
    DrawBar Me, 458
End Sub

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

Private Sub Commands_ButtonClick(ByVal Button As MSComctlLib.Button)
     
  Dim C    As Long
  Dim nSel As Long
  Dim fSel As Long
  Dim cSel As Long

    '-- 检查是否已经选中一个文件夹，如果没有选中
    If (Button.Index <= 2 And IDCat = "") Then
        '--  出现警告提示框
        MsgBox "选择一个文件夹", vbInformation, "Add pictures"
        Exit Sub
    End If
    
    '-- 重设控件
    Cancel_Save = False
    Me_back.Enabled = False
    Me_back2.Enabled = False
    Me_back3.Enabled = False
    
    '-- 重设进度条
    shpPerc.Width = 0
    lblPerc = "0%"
    
    Select Case Button.Key
    
    '-- 单击“添加所选图片”按钮
        Case "Add_Sel"
        
            '-- 获得选中的文件编号
            For C = 0 To File.ListCount - 1
                If (File.Selected(C) = True) Then
                    If (fSel = 0 And nSel = 0) Then fSel = C
                    nSel = nSel + 1
                End If
            Next C
            
            '-- 核对是否超过最大值
            If (GetThumbsNumber(IDCat) + nSel > 500) Then
                MsgBox "The number of thumbnails you are going to add" & vbCrLf & _
                       "exceeds maximum allowed (500 thumbnails per category)" & vbCrLf & vbCrLf & _
                       "Change your selection or create another category", _
                        vbExclamation, _
                       "Maximum exceeded"
                       
                '-- 将所有控件激活
                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
            Cancel_Process.SetFocus
            
            '-- 如果第一个图片文件没有被选中，那么将其设置为选中状态
            If (nSel > 0) Then
                If (File.ListIndex = fSel) Then File_Click
                If (File.ListIndex <> fSel) Then File.ListIndex = fSel
            End If
                            
                '-- 设置开始时间
                t = timeGetTime
                
                For C = fSel To File.ListCount - 1
                    '-- 假如单击“停止”按钮，停止继续添加相片
                    DoEvents
                    If (Cancel_Save = True) Then Exit For
                    If (File.Selected(C) = True) Then
                        '-- 如果选项被选择，则将其保存到数据库中
                        File.ListIndex = C
                        Save_to_DB
                        '-- 刷新进度条
                        shpPerc.Width = ((cSel + 1) * shpBack.Width) \ nSel
                        lblPerc = ((cSel + 1) * 100) \ nSel & "%"
                        '-- 刷新时间
                        lblTime = Format((timeGetTime - t) / 1000, "0.00 s.")
                        lblTime.Refresh
                        '-- 计数器加1
                        cSel = cSel + 1
                    End If
                Next C
                
            Saving_to_DB = False
            lblThumbs = Format(GetThumbsNumber(IDCat), "000") & "/500"
            
    '-- 单击“添加所有图片”按钮
        Case "Add_All"
        
            '-- 核对选择的图片文件是否超过500
            If (GetThumbsNumber(IDCat) + File.ListCount > 500) Then
                 '--  如果超过500个，出现警告提示框
                MsgBox "The number of thumbnails you are going to add" & vbCrLf & _
                       "exceeds maximum allowed (500 thumbnails per category)" & vbCrLf & vbCrLf & _
                       "Change your selection or create another category", _
                        vbExclamation, _
                       "Maximum exceeded"
                    
                '-- 激活所有控件
                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
            Cancel_Process.SetFocus
            
            '-- 如果第一个图片文件没有被选中，那么将其设置为选中状态
            If (File.ListIndex = 0) Then File_Click
            If (File.ListIndex <> 0) Then File.ListIndex = 0
                
                '-- 设置开始时间
                t = timeGetTime
                
                For C = 0 To File.ListCount - 1
                    '-- 假如单击"停止"按钮，停止继续添加相片
                    DoEvents
                    If (Cancel_Save = True) Then Exit For
                   '-- 如果选项被选择，则将其保存到数据库中
                    File.ListIndex = C
                    Save_to_DB
                    '-- 刷新进度条
                    shpPerc.Width = ((C + 1) * shpBack.Width) \ File_back.ListCount
                    lblPerc = ((C + 1) * 100) \ File_back.ListCount & "%"
                    '-- 刷新时间
                    lblTime = Format((timeGetTime - t) / 1000, "0.00 s.")
                    lblTime.Refresh
                Next C
                
            Saving_to_DB = False
            lblThumbs = Format(GetThumbsNumber(IDCat), "000") & "/500"
            
    '-- 单击“退出”按钮
        Case "Exit"
            '-- 退出窗体
            Me.Hide
            frmView.Hide
            frmMain.Enabled = True
    
    End Select
    
    '-- 将“停止”按钮设置为不可用
    Cancel_Process.Enabled = False
    '-- 激活其他所有的控件
    Me_back.Enabled = True
    Me_back2.Enabled = True
    Me_back3.Enabled = True
End Sub

'------------------------------------------------------------------------------
'树型结构：选择文件夹
'------------------------------------------------------------------------------

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)

    '-- 选择文件夹进行添加
    
    With Node
        '-- 获得结点文件夹编号
        IDCat = Right$(.Key, Len(.Key) - 1)
        '-- 刷新文件夹文件名标签
        lblSelectedCat = " " & .Text
        '--  如果没有发现文件夹
        If (IDCat = "") Then
            '--  显示打开文件个数的标签内容为空
            lblThumbs = ""
        Else '--  否则
            '--  显示打开文件个数
            lblThumbs = Format(GetThumbsNumber(IDCat), "000") & "/500"
        End If
    End With
End Sub

'------------------------------------------------------------------------------
' 树型结构: 文件夹以及图片文件控制 (查找文件)
'------------------------------------------------------------------------------

Private Sub btnExpandF_Click()
    '--  Dir树型目录不可见
    Dir.Visible = False
    '--  遍历Dir树型结构中选中文件夹的子文件夹，将将其展开
    For i = 1 To Dir.Nodes.Count
        If (Dir.Nodes(i).Children) Then
        If (Dir.Nodes(i).Child.Text <> "***") Then
        Dir.Nodes(i).Expanded = True
        End If
        End If
    Next i
    Dir.SelectedItem.EnsureVisible
    
    Dir.Visible = True
    Dir.SetFocus
End Sub

Private Sub btnContractF_Click()
'--  遍历Dir树型结构中选中文件夹的子文件夹，将将其收缩
    For i = 1 To Dir.Nodes.Count
        Dir.Nodes(i).Expanded = False
    Next i
    
    File.Clear
    Dir.SetFocus
End Sub

Private Sub Dir_NodeClick(ByVal Node As MSComctlLib.Node)

    '-- 刷新文件列表
    On Error GoTo DriveError
    File_back.Path = Node.Key
    ScanFiles
    Exit Sub
    '--  如果发现结点索引有两个，则出现“无法读取驱动器”警告提示对话框
DriveError:
    If (Node.Index = 2) Then
        MsgBox "无法读取驱动器", vbExclamation, Node.Text
    End If
End Sub

Private Sub Dir_Expand(ByVal Node As MSComctlLib.Node)
    '--  假如树型结构的子节点个数等于0或者大于1（每次只能打开一个子文件夹），退出程序
    If (Node.Children = 0 Or Node.Children > 1) Then Exit Sub
    '--  假如树型结构的字节点的文件夹的文件名不是字符串，退出程序
    If (Node.Child.Text <> "***") Then Exit Sub
    '--  打开子节点文件夹
    Dir.Nodes.Remove Node.Child.Index
    
    '-- 浏览子文件夹
    ScanFolders Node
End Sub

Private Sub File_Click()
    
    '-- 假如不是第一个文件