📄 db_explore.frm
字号:
Y1 = 8760
Y2 = 8760
End
Begin VB.Line Line2
BorderWidth = 2
X1 = 11760
X2 = 11760
Y1 = 4800
Y2 = 4680
End
Begin VB.Line Line5
X1 = 11640
X2 = 11880
Y1 = 4800
Y2 = 4800
End
Begin VB.Line Line4
X1 = 11640
X2 = 11760
Y1 = 4800
Y2 = 5040
End
Begin VB.Line Line3
X1 = 11760
X2 = 11880
Y1 = 5040
Y2 = 4800
End
Begin VB.Shape Shape5
BorderWidth = 2
Height = 9615
Left = 30
Top = 45
Width = 10215
End
Begin VB.Line Line1
X1 = 10920
X2 = 10920
Y1 = 6240
Y2 = 8520
End
Begin VB.Shape Shape4
FillColor = &H00E0E0E0&
FillStyle = 7 'Diagonal Cross
Height = 495
Left = 10440
Shape = 4 'Rounded Rectangle
Top = 8520
Width = 1140
End
Begin VB.Image Image1
Appearance = 0 'Flat
BorderStyle = 1 'Fixed Single
Height = 510
Left = 11520
Picture = "DB_explore.frx":47F4
ToolTipText = "Drop your item here to get his properties"
Top = 5040
WhatsThisHelpID = 3
Width = 510
End
Begin VB.Shape Shape1
BorderWidth = 4
Height = 1695
Left = 11040
Shape = 4 'Rounded Rectangle
Top = 4200
Width = 1455
End
Begin VB.Label Label3
Alignment = 2 'Center
Height = 1695
Left = 11040
TabIndex = 6
Top = 4200
Width = 1455
End
Begin VB.Label Label2
BackStyle = 0 'Transparent
Caption = "lab2"
Height = 255
Left = 10440
TabIndex = 4
Top = 1560
Visible = 0 'False
Width = 1455
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "lab1"
Height = 255
Left = 10440
TabIndex = 3
Top = 360
Visible = 0 'False
Width = 1335
End
Begin VB.Shape Shape3
FillColor = &H00E0E0E0&
FillStyle = 7 'Diagonal Cross
Height = 2415
Left = 10320
Shape = 4 'Rounded Rectangle
Top = 3840
Width = 2895
End
Begin VB.Shape Shape2
FillColor = &H00E0E0E0&
FillStyle = 5 'Downward Diagonal
Height = 2655
Left = 10320
Top = 0
Width = 2895
End
Begin VB.Shape Shape7
FillColor = &H00E0E0E0&
FillStyle = 7 'Diagonal Cross
Height = 1455
Left = 11040
Shape = 4 'Rounded Rectangle
Top = 6960
Width = 1695
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnufind
Caption = "&Find"
Enabled = 0 'False
Shortcut = ^F
End
Begin VB.Menu mnurefresh
Caption = "&Refresh"
Shortcut = {F5}
End
Begin VB.Menu sep12
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "&Exit"
End
End
Begin VB.Menu mnuview
Caption = "&View"
Begin VB.Menu mnularge
Caption = "Lar&ge icons"
Checked = -1 'True
Shortcut = ^G
End
Begin VB.Menu mnusmall
Caption = "S&mall icons"
Checked = -1 'True
Shortcut = ^M
End
Begin VB.Menu mnulist
Caption = "&List"
Checked = -1 'True
Shortcut = ^L
End
Begin VB.Menu mnudetails
Caption = "&Details"
Checked = -1 'True
Shortcut = ^D
End
Begin VB.Menu separator
Caption = "-"
End
Begin VB.Menu mnuarrange
Caption = "&Auto arrange"
Checked = -1 'True
Shortcut = ^A
End
End
Begin VB.Menu mnuhelp
Caption = "&Help"
NegotiatePosition= 3 'Right
Begin VB.Menu mnuwhat
Caption = "WhatsThis&?"
End
Begin VB.Menu separator12
Caption = "-"
End
Begin VB.Menu mnuabout
Caption = "&About"
Shortcut = ^H
End
Begin VB.Menu mnhlp
Caption = "&Help"
Shortcut = {F1}
End
End
Begin VB.Menu mnuaddnew
Caption = "&Addnew"
Begin VB.Menu mnuplayer
Caption = "add new &Player"
End
Begin VB.Menu mnustands
Caption = "add new &Stands"
End
Begin VB.Menu sep
Caption = "-"
End
Begin VB.Menu mnudel
Caption = "&Delete selected item"
End
Begin VB.Menu sepa12
Caption = "-"
End
Begin VB.Menu mnutrouve
Caption = "&Find"
Enabled = 0 'False
End
Begin VB.Menu separe12
Caption = "-"
End
Begin VB.Menu mnuproperties
Caption = "Proper&ties"
End
End
End
Attribute VB_Name = "DB_explore"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private DBtennis As Database
Private Mnode As Node 'stands
Private Mnode1 As Node 'pays
Private Mnode2 As Node 'sponsor
Private Mnode3 As Node 'sexe
Private Mnode4 As Node 'participant_complet
Private Mnode5 As Node 'Dates
Dim intIndex As Integer
Dim itmX As ListItem
Dim clmX As ColumnHeader
Private Sub Cmd_ok_Click()
label1.Visible = False
Label2.Visible = False
Text1.Visible = False
Text2.Visible = False
Cmd_ok.Visible = False
End Sub
Private Sub Cmd_ok_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Cmd_ok.FontBold = True
End Sub
Private Sub cmdload_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdload.FontBold = True
End Sub
Private Sub cmdquit_Click()
Unload Me
End Sub
Private Sub cmdquit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdquit.FontBold = True
End Sub
Private Sub Command1_Click()
ListView1.ListItems.Clear
End Sub
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command1.FontBold = True
End Sub
Private Sub Command2_Click()
Call rebuild
Call func_load
End Sub
Private Sub Command2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command2.FontBold = True
End Sub
Private Sub Datelist_Change()
For j = 1 To 100
var1 = Datelist.List(j)
var2 = Datelist.List(j + 1)
If var1 = var2 Then
Datelist.RemoveItem (j)
Else
DoEvents
End If
Next j
End Sub
Private Sub FindWhat_Click()
Call fct_find
End Sub
Private Sub FindWhat_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
FindWhat.FontBold = True
End Sub
Private Sub Form_Load()
'place & size
DB_explore.Left = 50
DB_explore.Top = 0
'DB_explore.Height = 8865
'DB_explore.Width = 7500
'CenterForm (Me)
mnularge.Checked = False
mnusmall.Checked = False
mnulist.Checked = False
mnudetails.Checked = True
mnuarrange.Checked = False
mnuaddnew.Visible = False
ListView1.View = lvwReport
Dim xc As Integer
For xc = 1 To 3
Set clmX = ListView1.ColumnHeaders.add()
If xc = 1 Then
clmX = "Properties"
ElseIf xc = 2 Then
clmX.text = "ID"
clmX.Width = 500
ElseIf xc = 3 Then
clmX.text = "Comments"
clmX.Width = 1750
End If
Next xc
Set DBtennis = DBEngine.Workspaces(0). _
OpenDatabase("tennis.MDB")
tvwDB.Sorted = True
Set Mnode = tvwDB.Nodes.add()
Mnode.text = "Stands"
Mnode.Tag = DBtennis.Name
Mnode.Image = "closed"
Set Mnode1 = tvwDB.Nodes.add
Mnode1.text = "Lands"
Mnode1.Tag = DBtennis.Name
Mnode1.Image = "closed"
Set Mnode2 = tvwDB.Nodes.add
Mnode2.text = "Sponsors"
Mnode2.Tag = DBtennis.Name
Mnode2.Image = "closed"
Set Mnode3 = tvwDB.Nodes.add
Mnode3.text = "Sexe"
Mnode3.Tag = DBtennis.Name
Mnode3.Image = "closed"
Set Mnode4 = tvwDB.Nodes.add
Mnode4.text = "Players"
Mnode4.Tag = DBtennis.Name
Mnode4.Image = "closed"
Set Mnode5 = tvwDB.Nodes.add
Mnode5.text = "Dates"
Mnode5.Tag = DBtennis.Name
Mnode5.Image = "closed"
Label3.Caption = "Drop a file here" & Chr(13) & "to erase it"
Call func_load
End Sub
Private Sub cmdLoad_Click()
Call func_load
mnufind.Enabled = True
mnutrouve.Enabled = True
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdload.FontBold = False
Cmd_ok.FontBold = False
cmdquit.FontBold = False
Command1.FontBold = False
Command2.FontBold = False
FindWhat.FontBold = False
End Sub
Private Sub Image1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i, current
current = ListView1.SelectedItem.Index
ListView1.ListItems.Remove (current)
End Sub
Private Sub Image2_Click()
Call rebuild
Call func_load
End Sub
Private Sub ListView1_DblClick()
Call get_Properties
End Sub
Private Sub ListView1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
DB_explore.PopupMenu mnuview
End If
End Sub
Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Set itmX = ListView1.ListItems.add()
If tvwDB.SelectedItem.Expanded = True Then
itmX.Icon = 1
itmX.SmallIcon = 1
itmX.text = tvwDB.SelectedItem.text
AutoKey = AutoKey + 1
Else
itmX.Icon = 3
itmX.SmallIcon = 3
itmX.text = tvwDB.SelectedItem.text
AutoKey = AutoKey + 1
End If
If cmdload.Enabled = True Then
itmX.Icon = 1
itmX.SmallIcon = 1
itmX.text = tvwDB.SelectedItem.text
AutoKey = AutoKey + 1
End If
End Sub
Private Sub ListView1_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
Image1.OLEDropMode = 1
End Sub
Private Sub mnhlp_Click()
Mainform.CommonDialog1.HelpFile = ".\help\help.hlp"
Mainform.CommonDialog1.HelpCommand = cdlHelpContents
Mainform.CommonDialog1.showHelp
End Sub
Private Sub mnuabout_Click()
frmSplash.Show
End Sub
Private Sub mnudel_Click()
Dim rep
rep = MsgBox("Are you sure do you want to delete " & tvwDB.SelectedItem.text & " ?", vbYesNo, "delete")
If rep = vbYes Then
fctDelete
Else
Exit Sub
End If
Call rebuild
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -