⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 frmmain.frm

📁 管理电子相片 可以进行上传 评价 浏览 等操作
💻 FRM
📖 第 1 页 / 共 5 页
字号:
🔍
12345 
    Fill_TreeCategories
    Fill_Thumbs ""
    
    '-- 初始化树型结构
    FullGrid.Cols = 4
    For i = 1 To FullGrid.Cols
        '-- 设置列宽
        FullGrid.ColWidth(i - 1) = Choose(i, 66, 176, 90, 64) * Screen.TwipsPerPixelX
        FullGrid.ColAlignment(i - 1) = Choose(i, flexAlignCenterCenter, flexAlignLeftCenter, flexAlignCenterCenter, flexAlignCenterCenter)
    Next i
    
    '-- 设置默认的开始位置
    optFilter.ListIndex = 0
End Sub

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

'------------------------------------------------------------------------------
' Toolbar: Choose DB / Add, rename & delete category / ...
'------------------------------------------------------------------------------

Public Sub Commands_ButtonClick(ByVal Button As MSComctlLib.Button)
                    
  Dim ID As String

    Select Case Button.Key
    '-- 选择数据库
        Case "Set_DB"
            
            frmDB.Left = Me.Left + 11 * Screen.TwipsPerPixelX
            frmDB.Top = Me.Top + (Me.Height - Me.ScaleHeight * Screen.TwipsPerPixelY) \ 2 + 34 * Screen.TwipsPerPixelY
            frmDB.Show vbModal
            
            If (Not frmDB.CancelDBSelection) Then
                Fill_TreeCategories
                Fill_Thumbs ""
            End If
            
    '-- 添加文件夹
        Case "Add_Cat"
      
            '-- 如果是根节点文件夹...:
            If (TreeView.SelectedItem.Key = "C" And TreeView.Nodes.Count > 1) Then
                '-- 弹出"请选择一个文件夹"提示对话框
                MsgBox "请选择一个文件夹", vbInformation, "Add Category"
                Exit Sub
            End If
              
            sResp = InputBox("输入文件名称 (max. 50) :", "添加文件夹", "New category")
                            
            '-- 如果在输入的文件名众出现单引号
            If (InStr(1, sResp, Chr(39))) Then
                '-- 弹出"不能接受单引号"提示对话框
                MsgBox "不能接受单引号", vbInformation, "Add category"
                Call Commands_ButtonClick(Commands.Buttons("Add_Cat"))
                Exit Sub
            End If
            
            If (Trim$(sResp) = "") Then Exit Sub
            
            '-- 停止运行
            Call Commands_ButtonClick(Commands.Buttons("Pause"))
            Commands.Buttons("Pause").Value = tbrPressed
            frmFull.opFull(0).Checked = False
            frmFull.opFull(1).Checked = True
                
            '-- 如果是根节点文件夹...:
            If (TreeView.SelectedItem.Key = "C") Then
                 '-- 设置ID等于"00"
                ID = "00"
               '-- 否则将文件的所处的层次赋予ID
              Else
                ID = Get_IDCat(TreeView.SelectedItem.Key, False)
            End If
              
            '-- 核对层次是否超过最大值
            If (Len(ID) = 0 Or Len(ID) > 202) Then
                MsgBox "Maximum exceeded: " & vbCrLf & vbCrLf & "Category added exceeds # 100", vbExclamation, "Add Category"
                Exit Sub
            End If
            
            '-- 添加新的目录
            DataCategories.Recordset.AddNew
            DataCategories.Recordset("IDCat") = ID
            DataCategories.Recordset("Category") = Left$(Trim$(sResp), 50)
            DataCategories.Recordset.Update
            
            '-- Fill Treeview
            Fill_TreeCategories
                             
            '-- 新添加的文件夹获得焦点
            TreeView.Nodes("C" & ID).Selected = True
            TreeView.Nodes("C" & ID).EnsureVisible
            Fill_Thumbs ""
            
            '-- 使“添加图片”按钮可用
            Commands.Buttons("Add_Pict").Enabled = True
                    
    '-- 添加一个子文件夹
        Case "Add_SubCat"
      
            '-- 如果是根节点文件夹...:
            If (TreeView.SelectedItem.Key = "C" And TreeView.Nodes.Count > 1) Then
                MsgBox "选择一个文件夹", vbInformation, "Add SubCategory"
                Exit Sub
            End If

            sResp = InputBox("输入文件名称 (max. 50) :", "添加子文件夹", "New SubCategory")
            
            '-- 如果在文件名中出现“单引号”
            If (InStr(1, sResp, Chr(39))) Then
                '出现"在文件名中不能出现单引号"提示对话框
                MsgBox "在文件名中不能出现单引号", vbInformation, "Add SubCategory"
                Call Commands_ButtonClick(Commands.Buttons("Add_SubCat"))
                Exit Sub
            End If
            
            If (Trim$(sResp) = "") Then Exit Sub
            
            '-- 停止运行
            Call Commands_ButtonClick(Commands.Buttons("Pause"))
            Commands.Buttons("Pause").Value = tbrPressed
            frmFull.opFull(0).Checked = False
            frmFull.opFull(1).Checked = True
            
           '-- 如果是根节点文件夹...:
            If (TreeView.SelectedItem.Key = "C") Then
                '-- 设置ID等于"00"
                ID = "00"
                '-- 否则将文件的所处的层次赋予ID
            Else
                ID = Get_IDCat(TreeView.SelectedItem.Key, True)
            End If
            
            '-- 核对层次是否超过最大值
            If (Len(ID) = 0 Or Len(ID) > 202) Then
                MsgBox "超过最大值 " & vbCrLf & vbCrLf & "子目录添加超过 # 100", vbExclamation, "Add Subcategory"
            End If
            
            '-- 添加新的目录
            DataCategories.Recordset.AddNew
            DataCategories.Recordset("IDCat") = ID
            DataCategories.Recordset("Category") = Left$(Trim$(sResp), 50)
            DataCategories.Recordset.Update
            
            '-- Fill Treeview
            Fill_TreeCategories
                             
            '-- 新添加的文件夹获得焦点
            TreeView.Nodes("C" & ID).Selected = True
            TreeView.Nodes("C" & ID).EnsureVisible
            Fill_Thumbs ""
            
            '-- 使“添加图片”按钮可用
            Commands.Buttons("Add_Pict").Enabled = True
    
      '-- 重命名一个文件夹
        Case "Ren_Cat"
      
            '-- 如果不是文件夹，退出:
            If DataCategories.Recordset.RecordCount = 0 Then Exit Sub
            
            '-- 如果是根节点文件夹...:
            If (TreeView.SelectedItem.Key = "C") Then
                 '-- 弹出 "选择一个文件夹"提示对话框
                MsgBox "选择一个文件夹", vbInformation, "重命名文件夹"
                Exit Sub
            End If
            '-- 出现输入对话框，在其中输入重命名的文件夹名，最大为50字符
            sResp = InputBox("输入最大值(最大值为50) :", "重命名文件夹", TreeView.SelectedItem)
            
            '-- 如果在文件名中出现单引号
            If (InStr(1, sResp, Chr(39))) Then
                 '-- 弹出 "不能出现单引号"提示对话框
                MsgBox "Character ['] not accepted", vbInformation, "Rename category"
                Call Commands_ButtonClick(Commands.Buttons("Ren_Cat"))
                Exit Sub
            End If
            
            If (Trim$(sResp) = "") Then Exit Sub
            
            '-- 编辑选择目录
            ID = TreeView.SelectedItem.Key
            DataCategories.Recordset.FindFirst "[IDCat]='" & Right$(ID, Len(ID) - 1) & "'"
            DataCategories.Recordset.Edit
            DataCategories.Recordset("Category") = Left$(Trim$(sResp), 50)
            DataCategories.Recordset.Update
            
            '-- Fill Treeview
            Fill_TreeCategories
                             
            '-- 重命名文件夹获得焦点
            TreeView.Nodes(ID).Selected = True
            TreeView.Nodes(ID).EnsureVisible

    '-- 删除一个文件夹
        Case "Del_Cat"
            
            '-- 如果没有文件夹，退出
            If (DataCategories.Recordset.RecordCount = 0) Then Exit Sub
            '-- 假如是根节点(DB)...:
            If (TreeView.SelectedItem.Key = "C") Then
               '-- 出现"这将删除所有的数据库内容. 是否继续?"提示对话框
                sResp = MsgBox("这将删除所有的数据库内容. 是否继续?", vbExclamation Or vbYesNo Or vbDefaultButton2, "删除数据连接")
              Else
                '-- 如果是文件夹，出现"所有子文件夹将被删除,删除文件夹 ?"提示对话框
                sResp = MsgBox("所有子文件夹将被删除" & vbCrLf & "删除文件夹 ?", vbExclamation Or vbYesNo Or vbDefaultButton2, "Delete category")
            End If
            
            If (sResp = vbNo) Then Exit Sub
            
            '-- 删除目录 (所有自文件夹将被删除)
            Dim tmpSource As String
            tmpSource = DataCategories.RecordSource
            
            DataCategories.RecordSource = "Select [IDCat] from tblCategories where [IDCat] LIKE '" & Right$(TreeView.SelectedItem.Key, Len(TreeView.SelectedItem.Key) - 1) & "*'"
            DataCategories.Refresh
            
            DataCategories.Recordset.MoveFirst
            Do Until DataCategories.Recordset.EOF
                DataCategories.Recordset.Delete
                DataCategories.Recordset.MoveNext
            Loop

            DataCategories.RecordSource = tmpSource
            DataCategories.Refresh
            
            '-- Fill Treeview
            Fill_TreeCategories
            Fill_Thumbs ""
            
    '-- 添加图片
        Case "Add_Pict"
            
            '--停止运行
            Call Commands_ButtonClick(Commands.Buttons("Pause"))
            Commands.Buttons("Pause").Value = tbrPressed
            frmFull.opFull(0).Checked = False
            frmFull.opFull(1).Checked = True
            
            '-- 隐藏“frmComments”窗体，隐藏说明窗体
            If (chkComments) Then
                chkComments = 0
                frmComments.Hide
                frmFull.opFull(19).Caption = "Show &comments"
            End If
            
            '-- 显示“frmAddtoDB”窗体，显示“添加图片”窗体
            frmAddtoDB.DataPictures.Refresh
            Me.Enabled = False
            frmAddtoDB.Show , Me
            
    '-- 全屏
        Case "Full"
            
            On Error Resume Next
            If tblSt(ThumbIndex) > 0 Then Exit Sub
             '--加入没有选择图片，退出
            If ThumbIsSelected = False Then Exit Sub
            
            frmFull.Image_Full.Visible = False
             '--在本窗体中显示“frmFull”窗体，也就是全屏窗体
            frmFull.Show , Me
            Show_Picture
            frmFull.Image_Full.Visible = True
            
            If (chkComments) Then frmComments.Show , frmFull
            frmFull.SetFocus
            
    '-- 上一张
        Case "Previous"
            
            Select_Thumb (-1)
                
    '-- 下一张
        Case "Next"
        
            Select_Thumb (1)
            
    '-- 开始播放
        Case "Play"
      
            timerShowPictures.Enabled = True
            frmFull.opFull(0).Checked = True
            frmFull.opFull(1).Checked = False
        
    '-- 停止播放
        Case "Pause"
            
            timerShowPictures.Enabled = False
            frmFull.opFull(0).Checked = False
            frmFull.opFull(1).Checked = True
            
    '-- 第一张
        Case "First"
            
            ThumbIndex = 1
            Select_Thumb (0)
        
    '-- 最后一张
        Case "Last"
        
            ThumbIndex = UBound(tblID)
            Select_Thumb (0)
    
    End Select
End Sub

Private Sub CommandExit_ButtonClick(ByVal Button As MSComctlLib.Button)

    '-- 退出电子相片管理系统
    '-- 关闭所有的数据库和数据集
    DataPictures.Recordset.Close
    DataCategories.Recordset.Close
    DataCategories.Database.Close
     '-- 卸载所有窗体
    Unload frmAbout
    Unload frmAddtoDB
    Unload frmComments
    Unload frmDB
    Unload frmHelp
    Unload frmFull
    Unload frmView
    Unload Me
    
    Set frmAbout = Nothing
    Set frmAddtoDB = Nothing
    Set frmComments = Nothing
    Set frmDB = Nothing
    Set frmHelp = Nothing
    Set frmFull = Nothing
    Set frmView = Nothing
    Set frmMain = Nothing
End Sub

'------------------------------------------------------------------------------
' Treeview (Categories)
'------------------------------------------------------------------------------

Private Sub btnExpand_Click()
    '--树型结构控件不可见
    TreeView.Visible = False
    '--  遍历树型结构控件中的结点
    For i = 1 To TreeView.Nodes.Count
         '--  展开结点文件夹
        TreeView.Nodes(i).Expanded = True
    Next i
     '-- 使用蓝色显示选中的选项
    TreeView.SelectedItem.EnsureVisible
    '--树型结构控件可见
    TreeView.Visible = True
End Sub

Private Sub btnContract_Click()
    '--  遍历树型结构控件中的结点
    For i = 1 To TreeView.Nodes.Count
        '--  收缩结点文件夹
        TreeView.Nodes(i).Expanded = False
    Next i
12345

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -