frmaddtodb.frm

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

    If (File.ListIndex <> -1) Then
        '--  假如不是最后一个文件并且文件可见
        If (File.ListIndex <> LastIndex And File.Visible) Then
            '--  获得缩略图
            Get_Thumbnail
            LastIndex = File.ListIndex
        End If
    End If
End Sub

Private Sub ScanFolders(ByVal Node As MSComctlLib.Node)

  Dim fld As Scripting.Folder
  Dim nd  As Node
    
    Screen.MousePointer = vbArrowHourglass
    Dir.Visible = False
    
    On Error GoTo DriveError
    For Each fld In FSO.GetFolder(Node.Key).SubFolders
        Set nd = Dir.Nodes.Add(Node, tvwChild, fld.Path, fld.Name, 7, 9)
        nd.Sorted = True
        If (fld.SubFolders.Count) Then
            Dir.Nodes.Add nd.Index, tvwChild, , "***"
        End If
    Next
    
    Dir.Visible = True
    Screen.MousePointer = vbDefault
    Exit Sub
    
DriveError:
    Dir.Visible = True
    Screen.MousePointer = vbDefault
    MsgBox "无法读取驱动器", vbExclamation, Node.Text
End Sub

Private Sub ScanFiles()
  
  Dim tmpExt As String
    
  Dim itmx     As ListItem
  Dim FilePath As String
  Dim TotalKb  As Long

    '-- 设置新的文件模式
    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
        '-- 没有选择类型
        File_back.Pattern = "*.no_files"
      Else
        '-- 刷新文件模式
        tmpExt = Left$(tmpExt, Len(tmpExt) - 1)
        File_back.Pattern = tmpExt
    End If
    
    '-- 屏幕的鼠标类型vbArrowHourglass
    Screen.MousePointer = vbArrowHourglass
        
        '-- 清除缩略图以及图片文件信息
        Image_Thumbnail = LoadPicture()
        lblName = ""
        lblSize = ""
        lblWidth = ""
        lblHeight = ""
        
        '-- 清除文件列表
        File.Clear
        LastIndex = -1
        '-- 文件列表不可见
        File.Visible = False
        TotalKb = 0  '-- 文件总大小清零
        
        For i = 0 To File_back.ListCount - 1
             '-- 得到路径
             FilePath = File_back.Path & IIf(Right$(File_back.Path, 1) <> "\", "\", "") & File_back.List(i)
             '-- 添加文件到列表
             File.AddItem File_back.List(i)
             '-- 得到文件的总大小
             TotalKb = TotalKb + FileLen(FilePath)
        Next i
        
        '-- 显示文件信息
        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()
  '-- 设置变量
  Dim tmpItem     As Long
  Dim tmpTopItem  As Long
  Dim tmpchkThumb As Long
    '-- 假如文件列表中文件个数为0，退出程序
    If (File.ListCount = 0) Then Exit Sub
    
    Screen.MousePointer = vbArrowHourglass
        
        '-- 文件列表不可见
        File.Visible = False
        '-- 得到临时的文件列表索引
        tmpItem = File.ListIndex
        tmpTopItem = File.TopIndex
        tmpchkThumb = chkThumb: chkThumb = 0
        '-- 实现反选功能
        For i = 0 To File.ListCount - 1
            File.Selected(i) = Not File.Selected(i)
        Next i
        '-- 恢复文件类别索引
        File.ListIndex = tmpItem
        File.TopIndex = tmpTopItem
        chkThumb = tmpchkThumb
        '-- 文件列表可见
        File.Visible = True
        
    Screen.MousePointer = vbDefault
End Sub

'------------------------------------------------------------------------------
' Get and resize picture to Thumbnail
'------------------------------------------------------------------------------

Private Sub Get_Thumbnail()
    
  Dim relWH As Single
  Dim W     As Long
  Dim H     As Long
  Dim oldMd As Long
  
    If (chkThumb = 0 And Saving_to_DB = False) Then Exit Sub
    
    Screen.MousePointer = vbArrowHourglass
    Image_Thumbnail.Visible = False
            
        '-- 得到图片文件的路径
        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
                '-- 如果缺少图片或者有其他的错误
                sResp = MsgBox("Error loading picture :" & vbCrLf & vbCrLf & File.List(File.ListIndex), vbOKCancel Or vbCritical, "Thumb DB")
                '-- 取消图片的保存
                Saving_to_DB = False
                Screen.MousePointer = vbDefault
                '-- 没有进行保存操作
                If (sResp = vbCancel) Then
                    Cancel_Save = True
                End If
                Exit Sub
            End If
            
        '-- 计算缩略图大小
        
        W = iLoaded.Width
        H = iLoaded.Height
        
        If (W > THUMB_MAX_SIZE Or H > THUMB_MAX_SIZE) Then
            If (W > H) Then
                '-- 伸展缩略图宽度
                Image_Thumbnail.Width = THUMB_MAX_SIZE
                Image_Thumbnail.Height = (H / W) * THUMB_MAX_SIZE
              Else
                '-- 伸展缩略图高度
                Image_Thumbnail.Height = THUMB_MAX_SIZE
                Image_Thumbnail.Width = (W / H) * THUMB_MAX_SIZE
            End If
            '-- 调整缩略图大小
            oldMd = GetStretchBltMode(Image_Thumbnail.hdc)
            SetStretchBltMode Image_Thumbnail.hdc, COLORONCOLOR
            StretchBlt Image_Thumbnail.hdc, 0, 0, Image_Thumbnail.Width, Image_Thumbnail.Height, iLoaded.hdc, 0, 0, iLoaded.Width, iLoaded.Height, SRCCOPY
            SetStretchBltMode Image_Thumbnail.hdc, oldMd
          Else
            '-- 没有伸展
            Image_Thumbnail = iLoaded
        End If
        
        '-- 绘制缩略图边界
        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
        '-- 得到实际图片的大小
        Set Image_Thumbnail = Image_Thumbnail.Image
        '-- 显示图片的属性
        lblName = File.List(File.ListIndex)
        lblSize = Format(FileLen(FilePath) \ 1024, "##,##0 Kb")
        lblWidth = Format(W, "##,##")
        lblHeight = Format(H, "##,##")
        '-- 确定缩略图位置
        Image_Thumbnail.Left = 280 + (79 - Image_Thumbnail.Width) \ 2
        Image_Thumbnail.Top = 374 + (79 - Image_Thumbnail.Height) \ 2
            
    Image_Thumbnail.Visible = True
    Screen.MousePointer = vbDefault
    
    '-- 更新预览模块
    If (frmView.Visible) Then
        Set frmView.View = iLoaded
        frmView.View.BestFit
    End If
End Sub

Private Sub chkThumb_Click()
    If (Not chkThumb) Then LastIndex = -1
End Sub

'------------------------------------------------------------------------------
' Saving to DB
'------------------------------------------------------------------------------

Private Sub Cancel_Process_Click()
    '-- 停止添加图片进程
    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
            '-- 将图片添加搭配数据库
            .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
        '-- 从tblPictures数据表中得到指定的记录集
        .RecordSource = "Select * from tblPictures where [IDCat] = '" & IDCat & "'"
        .Refresh
        '-- 填充记录集
        If (.Recordset.RecordCount > 0) Then
            .Recordset.MoveFirst
            .Recordset.MoveLast
        End If
        '-- 得到记录集中记录的个数
        GetThumbsNumber = .Recordset.RecordCount
        '-- 关闭记录集
        .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
    
    '-- 在frmView窗体中显示与Image_Thumbnail图片框中相同的图片
    Set frmView.View = iLoaded
    '--图片以最适合的大小显示
    frmView.View.BestFit
    '-- 显示frmView窗体
    frmView.Show , Me
End Sub

'------------------------------------------------------------------------------
' Add drives to TreeView
'------------------------------------------------------------------------------

Sub DirRefresh()

  Dim Dr  As Drive
  Dim SDL As String
  Dim rootnd As Node, nd As Node
        
    Set rootnd = Dir.Nodes.Add(, , "PC", "Local", 1, 1)
    rootnd.Expanded = True
        
    On Error Resume Next

    For Each Dr In FSO.Drives
    
        SDL = UCase$(Dr.DriveLetter) & ":"
        
        If (Dr.DriveType = Removable) Then
            Set nd = Dir.Nodes.Add("PC", tvwChild, SDL & "\", SDL, "floppy", "floppy")
        ElseIf (Dr.DriveType = CDRom) Then
            Set nd = Dir.Nodes.Add("PC", tvwChild, SDL & "\", SDL, "cd", "cd")
        ElseIf (Dr.DriveType = Fixed) Then
            Set nd = Dir.Nodes.Add("PC", tvwChild, SDL & "\", SDL, "fixed", "fixed")
        ElseIf (Dr.DriveType = Remote) Then
            Set nd = Dir.Nodes.Add("PC", tvwChild, SDL & "\", SDL, "remote", "remote")
        Else
            Set nd = Dir.Nodes.Add("PC", tvwChild, SDL & "\", SDL, "unknown", "unknown")
        End If
        
        nd.Sorted = True
        Dir.Nodes.Add nd, tvwChild, , "***"
    Next Dr
    
    Set FSO = Nothing
    
    On Error GoTo 0
End Sub