📄 frmcontacts.frm
字号:
BackStyle = 1 'Opaque
Height = 255
Index = 25
Left = 3360
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 26
Left = 3600
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 19
Left = 1920
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 20
Left = 2160
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 21
Left = 2400
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 22
Left = 2640
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 23
Left = 2880
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 14
Left = 720
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 15
Left = 960
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 16
Left = 1200
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 17
Left = 1440
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 18
Left = 1680
Shape = 4 'Rounded Rectangle
Top = 3920
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 13
Left = 3720
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 12
Left = 3480
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 11
Left = 3240
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 10
Left = 3000
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 9
Left = 2760
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 8
Left = 2520
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 7
Left = 2280
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 6
Left = 2040
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 5
Left = 1800
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 4
Left = 1560
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 3
Left = 1320
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 2
Left = 1080
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 1
Left = 840
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Shape shapeAlpha
BackStyle = 1 'Opaque
Height = 255
Index = 0
Left = 600
Shape = 4 'Rounded Rectangle
Top = 3675
Width = 255
End
Begin VB.Line Line2
BorderWidth = 2
X1 = 4560
X2 = 4560
Y1 = 240
Y2 = 5280
End
Begin VB.Label lblCaption
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Hirdhav Digital Diary - Contacts"
Height = 225
Left = 195
TabIndex = 0
Top = 15
Width = 2700
End
Begin VB.Line Line1
BorderWidth = 2
X1 = 15
X2 = 15
Y1 = 240
Y2 = 5280
End
Begin VB.Shape shapeCaption
BackStyle = 1 'Opaque
BorderWidth = 2
Height = 255
Left = 15
Top = 15
Width = 4560
End
End
Attribute VB_Name = "frmContacts"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public tmpUsername As String
Public tmpAlpha As String
Private Sub comContacts_Click()
If comContacts.Text = "Buisness" Then
HDDMsgBox "Sorry, Not available It will be available very soon."
'lstName.Width = "3885"
'lstInfo.Visible = False
comContacts.ListIndex = 0
End If
If comContacts.Text = "Personal" Then
lstName.Width = "2025"
lstInfo.Width = "1860"
lstInfo.Visible = True
lstName.Visible = True
End If
End Sub
Private Sub Form_Load()
comContacts.AddItem "Personal"
comContacts.AddItem "Buisness"
comContacts.BackColor = RGB(145, 155, 100)
shapeCaption.BackColor = vbBlack
shapeEdit.BackColor = RGB(145, 155, 100)
shapeDelete.BackColor = RGB(145, 155, 100)
lblCaption.ForeColor = RGB(145, 155, 100)
lstNew.BackColor = RGB(145, 155, 100)
lstNew.AddItem "Personal"
lstNew.AddItem "Buisness"
shapeNew.BackColor = RGB(145, 155, 100)
tmpUsername = frmMain.lblUsername.Caption
Me.BackColor = RGB(145, 155, 100)
lstName.BackColor = RGB(145, 155, 100)
lstInfo.BackColor = RGB(145, 155, 100)
shapeAlpha(0).BackColor = vbBlack
lblAlpha(0).ForeColor = RGB(145, 155, 100)
shapeMainMenu.BackColor = RGB(145, 155, 100)
tmpAlpha = "A"
For I = 1 To 26
shapeAlpha(I).BackColor = RGB(145, 155, 100)
Next I
For I = 1 To 13
lblAlpha(I).ForeColor = vbBlack
Next I
If comContacts.Text = "Personal" Then
'Open database and add contacts names in to the list
Dim db As Database
Dim ReS As Recordset
Set db = OpenDatabase(App.Path + "\Data\" + tmpUsername + "\Personal.dat")
Set ReS = db.OpenRecordset("A")
On Error GoTo HanErr:
Do
lstName.AddItem ReS("Name")
lstInfo.AddItem ReS("Phone(H)")
ReS.MoveNext
Loop
End If
HanErr:
If Err.Number = 3021 Then
End If
ReS.Close
db.Close
Set ReS = Nothing
Set db = Nothing
End Sub
Private Sub lblAlpha_Click(Index As Integer)
Dim AlphaNo As Integer
AlphaNo = lblAlpha(Index).Index
For I = 0 To 26
shapeAlpha(I).BackColor = RGB(145, 155, 100)
lblAlpha(I).ForeColor = vbBlack
Next I
shapeAlpha(AlphaNo).BackColor = vbBlack
lblAlpha(AlphaNo).ForeColor = RGB(145, 155, 100)
'Clear the list boxes
lstName.Clear
lstInfo.Clear
'Open database and add Contacts in list boxes.
Dim db As Database
Dim ReS As Recordset
Set db = OpenDatabase(App.Path + "\Data\" + tmpUsername + "\Personal.dat")
Set ReS = db.OpenRecordset(lblAlpha(AlphaNo).Caption)
tmpAlpha = lblAlpha(AlphaNo).Caption
On Error GoTo HanErr:
Do
lstName.AddItem ReS("Name")
lstInfo.AddItem ReS("Phone(H)")
ReS.MoveNext
Loop
HanErr:
If Err.Number = 3021 Then
End If
lstName.SetFocus
End Sub
Private Sub lblCaptionSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
DragForm Me
End Sub
Private Sub lblDeleteSupport_Click()
If lstName.ListIndex = "-1" Then
HDDMsgBox "Please selct the contact from the list."
Else
HDDYesNoBox "Do you want to delete it?"
If Yes Then
Dim db As Database
Dim ReS As Recordset
Set db = OpenDatabase(App.Path + "\Data\" + tmpUsername + "\Personal.dat")
Set ReS = db.OpenRecordset(tmpAlpha)
ReS.Move (lstName.ListIndex)
ReS.Delete
ReS.Close
db.Close
Set ReS = Nothing
Set db = Nothing
HDDMsgBox "Contact deleted successfully."
Unload Me
frmContacts.Show
End If
End If
End Sub
Private Sub lblDeleteSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblDelete.ForeColor = RGB(145, 155, 100)
shapeDelete.BackColor = vbBlack
End Sub
Private Sub lblDeleteSupport_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
shapeDelete.BackColor = RGB(145, 155, 100)
lblDelete.ForeColor = vbBlack
End Sub
Private Sub lblEditSupport_Click()
If lstName.ListIndex = "-1" Then
HDDMsgBox "Please select the contact from the list."
Else
frmContactsEdit.Show
Me.Hide
End If
End Sub
Private Sub lblEditSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblEdit.ForeColor = RGB(145, 155, 100)
shapeEdit.BackColor = vbBlack
End Sub
Private Sub lblEditSupport_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblEdit.ForeColor = vbBlack
shapeEdit.BackColor = RGB(145, 155, 100)
End Sub
Private Sub lblMainMenuSupport_Click()
frmMain.Show
Unload Me
End Sub
Private Sub lblMainMenuSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblMainMenu.ForeColor = RGB(145, 155, 100)
shapeMainMenu.BackColor = vbBlack
End Sub
Private Sub lblMainMenuSupport_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblMainMenu.ForeColor = vbBlack
shapeMainMenu.BackColor = RGB(145, 155, 100)
End Sub
Private Sub lblNewSupport_Click()
frmNewPersonal.Show
Me.Hide
End Sub
Private Sub lblNewSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblNew.ForeColor = RGB(145, 155, 100)
shapeNew.BackColor = vbBlack
End Sub
Private Sub lblNewSupport_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblNew.ForeColor = vbBlack
shapeNew.BackColor = RGB(145, 155, 100)
End Sub
Private Sub lstInfo_Click()
lstName.ListIndex = lstInfo.ListIndex
End Sub
Private Sub lstInfo_DblClick()
If lstName.ListIndex = "-1" Then
HDDMsgBox "Please select the contact from the list."
Else
frmContactsDetails.Show
Me.Hide
End If
End Sub
Private Sub lstName_Click()
lstInfo.ListIndex = lstName.ListIndex
End Sub
Private Sub lstName_DblClick()
If lstName.ListIndex = "-1" Then
HDDMsgBox "Please select the contact from the list."
Else
frmContactsDetails.Show
Me.Hide
End If
End Sub
Private Sub lstNew_Click()
If lstNew.Text = "Personal" Then
frmNewPersonal.Show
Me.Hide
End If
If lstNew.Text = "Buisness" Then
HDDMsgBox "Sorry, Not available It will be available very soon."
End If
End Sub
Private Sub lstNew_LostFocus()
lstNew.Visible = False
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -