📄 frmmain.frm
字号:
Width = 3930
_ExtentX = 6932
_ExtentY = 4948
_Version = 393217
HideSelection = 0 'False
Indentation = 265
LabelEdit = 1
Style = 7
ImageList = "Icons"
BorderStyle = 1
Appearance = 0
End
Begin Thumb_DB.ucGraphicButton btnContract
Height = 180
Left = 2055
ToolTipText = "Contract all"
Top = 855
Width = 240
_ExtentX = 423
_ExtentY = 318
End
Begin Thumb_DB.ucGraphicButton btnExpand
Height = 180
Left = 3090
ToolTipText = "Expand all"
Top = 855
Width = 240
_ExtentX = 423
_ExtentY = 318
End
Begin VB.Shape shpCategoriesBack
BackStyle = 1 'Opaque
Height = 2805
Left = 120
Top = 1050
Width = 3930
End
Begin VB.Label lblExpand
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Expand"
ForeColor = &H00000000&
Height = 180
Left = 3405
TabIndex = 27
Top = 840
Width = 555
End
Begin VB.Label lblContract
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Contract"
ForeColor = &H00000000&
Height = 180
Left = 2355
TabIndex = 26
Top = 840
Width = 660
End
Begin VB.Label lblPreview
BackStyle = 0 'Transparent
Caption = "Best Fit"
ForeColor = &H00000000&
Height = 165
Left = 3390
TabIndex = 25
Top = 3855
Width = 675
End
Begin VB.Shape shpPreviewBack
BackStyle = 1 'Opaque
Height = 3930
Left = 120
Top = 4065
Width = 3930
End
Begin VB.Line Line2
X1 = 676
X2 = 676
Y1 = 56
Y2 = 73
End
Begin VB.Label lblPreviewBar
Appearance = 0 'Flat
BackColor = &H0000C000&
BorderStyle = 1 'Fixed Single
Caption = " Preview"
ForeColor = &H00000000&
Height = 240
Left = 120
TabIndex = 10
Top = 3840
Width = 3930
End
Begin VB.Label lblCategoriesBar
Appearance = 0 'Flat
BackColor = &H0000C000&
BorderStyle = 1 'Fixed Single
Caption = " Categories"
ForeColor = &H00000000&
Height = 240
Left = 120
TabIndex = 3
Top = 825
Width = 3930
End
Begin VB.Label InfoCategory
Appearance = 0 'Flat
BackColor = &H0000C000&
BorderStyle = 1 'Fixed Single
ForeColor = &H00000000&
Height = 240
Left = 4200
TabIndex = 6
Top = 825
Width = 6180
End
Begin VB.Menu ThumbMenu
Caption = "ThumbMenu"
Visible = 0 'False
Begin VB.Menu OpThumb
Caption = "&Info"
Index = 0
End
Begin VB.Menu OpThumb
Caption = "-"
Index = 1
End
Begin VB.Menu OpThumb
Caption = "&Edit picture"
Index = 2
End
Begin VB.Menu OpThumb
Caption = "Copy to clipboard (&Thumbnail)"
Index = 3
End
Begin VB.Menu OpThumb
Caption = "Copy to clipboard (&Picture)"
Index = 4
End
Begin VB.Menu OpThumb
Caption = "-"
Index = 5
End
Begin VB.Menu OpThumb
Caption = "&Delete thumbnail"
Index = 6
End
Begin VB.Menu OpThumb
Caption = "-"
Index = 7
End
Begin VB.Menu OpThumb
Caption = "&Cancel"
Index = 8
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' ==================
' Thumb DB 1.5
' ==================
' Carles P.V. - 2001
' carles_pv@terra.es
' ==================
' Last Md.: 10/27/01
' # [Main code]:
' * Toolbar : Choose DB, Add, rename, delete category,...
' * Treeview : Category (Select, move to, copy to...)
' * Filter control : Thumbnail filters
' * ThumbGrid control : Thumbnail grid
' * FullGrid control : Full Thumbnail grid (all fields)
' * Preview control : Picture preview
' * ThumbGrid/FullGrid modes: View modes
' * Thumbnail/Preview menu : Thumbnail info, clipboard methods,...
' * Key control : Quick keys (Move on grid, full screen,...)
' * Show/Hide Preview : Preview chkBox
' * Show/Hide Comments : Comments field chkBox
' * Fast help... : 'Help' screen
' * About me... : 'About me' screen
' ...
' # [Private subs]:
' * Fill Categories : Fill categories from DB
' * Fill thumbnail Grids : Fill ThumbGrid/FullGrid from DB
' * Get_IDCat : Get first free ID (00-99)
' * Select_Thumb : Thumbnail selection (DB)
' * Show_Picture : Show picture (Preview/Full Screen views)
' * Load_Picture : Load picture by DB path
' * Timer : Start/Stop playing
Option Explicit
Private Sub Form_Load()
'## Get default database: [Thumbs.mdb]
Load frmDB
'## Fill categories and initialize grids
Fill_TreeCategories
Fill_Thumbs ""
'## Initialize FullGrid
FullGrid.Cols = 4
For I = 1 To FullGrid.Cols
'# Set columns width
FullGrid.ColWidth(I - 1) = Choose(I, 990, 2640, 1350, 960)
'# Set columns alignment
FullGrid.ColAlignment(I - 1) = Choose(I, flexAlignCenterCenter, _
flexAlignLeftCenter, _
flexAlignCenterCenter, _
flexAlignCenterCenter)
Next I
'## Set default find criteria (Start)
optFilter.ListIndex = 0
'## Draw decorative bars
DrawBar Me, 0
DrawBar Me, 27
DrawBar Me, 536
'## New line
NL = vbNewLine
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
'## Select Database
Case "Set_DB"
frmDB.Left = Me.Left + 165
frmDB.Top = Me.Top + (Me.Height - Me.ScaleHeight * 15) / 2 + 510
frmDB.Show vbModal
Fill_TreeCategories
Fill_Thumbs ""
'## Add a category
Case "Add_Cat"
'# If root node...:
If TreeView.SelectedItem.Key = "C" And _
TreeView.Nodes.Count > 1 Then
MsgBox "Select a category", vbInformation, "Add Category"
Exit Sub
End If
Resp = InputBox("Enter name (max. 50) :", _
"Add category", _
"New category")
'# Apostrophe not accepted:
If InStr(1, Resp, Chr(39)) Then
MsgBox "Character ['] not accepted", _
vbInformation, _
"Add category"
Call Commands_ButtonClick(Commands.Buttons("Add_Cat"))
Exit Sub
End If
If Trim(Resp) = "" Then Exit Sub
'# Stop playing
Call Commands_ButtonClick(Commands.Buttons("Pause"))
Commands.Buttons("Pause").Value = tbrPressed
frmFull.opFull(0).Checked = False
frmFull.opFull(1).Checked = True
'# If root node: ID = main first ID / else: get level ID
If TreeView.SelectedItem.Key = "C" Then
ID = "00"
Else
ID = Get_IDCat(TreeView.SelectedItem.Key, False)
End If
'# Check if maximum is exceeded
If Len(ID) = 0 Or Len(ID) > 202 Then
MsgBox "Maximum exceeded: " & NL & NL & _
"Category added exceeds # 100", _
vbExclamation, _
"Add Category"
Exit Sub
End If
'# Add new entry
DataCategories.Recordset.AddNew
DataCategories.Recordset("IDCat") = ID
DataCategories.Recordset("Category") = Left(Trim(Resp), 50)
DataCategories.Recordset.Update
'# Fill Treeview
Fill_TreeCategories
'# Select added item
TreeView.Nodes("C" & ID).Selected = True
TreeView.Nodes("C" & ID).EnsureVisible
Fill_Thumbs ""
'# Enable 'Add pictures' button
Commands.Buttons("Add_Pict").Enabled = True
'## Add a SubCategory
Case "Add_SubCat"
'# If root node...:
If TreeView.SelectedItem.Key = "C" And _
TreeView.Nodes.Count > 1 Then
MsgBox "Select a category", vbInformation, "Add SubCategory"
Exit Sub
End If
Resp = InputBox("Enter name (max. 50) :", _
"Add SubCategory", _
"New SubCategory")
'# Apostrophe not accepted:
If InStr(1, Resp, Chr(39)) Then
MsgBox "Character ['] not accepted", _
vbInformation, _
"Add SubCategory"
Call Commands_ButtonClick(Commands.Buttons("Add_SubCat"))
Exit Sub
End If
If Trim(Resp) = "" Then Exit Sub
'# Stop playing
Call Commands_ButtonClick(Commands.Buttons("Pause"))
Commands.Buttons("Pause").Value = tbrPressed
frmFull.opFull(0).Checked = False
frmFull.opFull(1).Checked = True
'# If root node: ID = main first ID / else: get sublevel ID
If TreeView.SelectedItem.Key = "C" Then
ID = "00"
Else
ID = Get_IDCat(TreeView.SelectedItem.Key, True)
End If
'# Check if maximum is exceeded
If Len(ID) = 0 Or Len(ID) > 202 Then
MsgBox "Maximum exceeded: " & NL & NL & _
"Subcategory added exceeds # 100", _
vbExclamation, _
"Add Subcategory"
End If
'# Add new entry
DataCategories.Recordset.AddNew
DataCategories.Recordset("IDCat") = ID
DataCategories.Recordset("Category") = Left(Trim(Resp), 50)
DataCategories.Recordset.Update
'# Fill Treeview
Fill_TreeCategories
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -