📄 mainfrm.frm
字号:
Width = 900
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "联系地址："
Height = 180
Index = 11
Left = 135
TabIndex = 30
Top = 2880
Width = 900
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "生 日："
Height = 180
Index = 10
Left = 135
TabIndex = 29
Top = 1305
Width = 720
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "农 历："
Height = 180
Index = 9
Left = 2790
TabIndex = 28
Top = 1305
Width = 630
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = " ICQ ："
Height = 180
Index = 8
Left = 2790
TabIndex = 27
Top = 2385
Width = 630
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "QQ号码："
Height = 180
Index = 7
Left = 135
TabIndex = 26
Top = 2385
Width = 720
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = " MSN ："
Height = 180
Index = 6
Left = 135
TabIndex = 25
Top = 1980
Width = 720
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "电 话："
Height = 180
Index = 5
Left = 2790
TabIndex = 24
Top = 945
Width = 630
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "E-mail："
Height = 180
Index = 4
Left = 135
TabIndex = 23
Top = 1620
Width = 720
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "性 别："
Height = 180
Index = 3
Left = 135
TabIndex = 22
Top = 945
Width = 720
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "英文名："
Height = 180
Index = 1
Left = 135
TabIndex = 21
Top = 585
Width = 720
End
Begin VB.Label L1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "姓 名："
Height = 180
Index = 0
Left = 135
TabIndex = 20
Top = 225
Width = 720
End
End
Begin VB.Menu mTVMenu
Caption = "TVMenu"
Visible = 0 'False
Begin VB.Menu m_Open
Caption = "展开联系人组(&O)"
End
Begin VB.Menu m_Close
Caption = "收起联系人组(&C)"
End
Begin VB.Menu m_Line0Z
Caption = "-"
End
Begin VB.Menu m_Clear
Caption = "清空已删除联系人"
End
Begin VB.Menu m_Line00
Caption = "-"
End
Begin VB.Menu M_New
Caption = "添加新的联系人(&N)"
End
Begin VB.Menu M_Edit
Caption = "编辑联系人资料(&E)"
End
Begin VB.Menu m_Del
Caption = "删除当前联系人"
End
Begin VB.Menu m_Find
Caption = "查找联系人(&F)"
End
Begin VB.Menu m_Line01
Caption = "-"
End
Begin VB.Menu M_NewR
Caption = "添加新的用户组"
End
Begin VB.Menu m_DelR
Caption = "删除此用户组(&D)"
End
Begin VB.Menu m_NameR
Caption = "重命名用户组(&R)"
End
Begin VB.Menu m_Line02
Caption = "-"
End
Begin VB.Menu m_Remove
Caption = "移动到组...(&M)"
End
End
End
Attribute VB_Name = "MainFrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Type TypeNotNode
ID As Long
ZB As Long
End Type
Private MoveFlag As Boolean, MoveExpanded As Boolean, SelCombo As ComboBox
Private MoveNode As Node, EditIndex As Long, ComboListIndex(5) As Long
Private Sub CEdit_Click(Index As Integer)
Dim i As Long, Length As Long
On Error Resume Next
TB1.Buttons("tSave").Enabled = True
If SelCombo Is Nothing Then Exit Sub
If SelCombo.ListCount < 1 And Index > 0 Then SelCombo.ListIndex = -1: Exit Sub
For i = 0 To SelCombo.ListCount - 1
If UCase(Trim(SelCombo.Text)) = UCase(Trim(SelCombo.List(i))) Then
If Index = 2 Then '删除条目操作：如果没有此条目，则显示第一条
SelCombo.RemoveItem i
If SelCombo.ListCount < 1 Then
ComboListIndex(SelCombo.Index) = -1
SelCombo.ListIndex = -1
CEdit(2).Enabled = False
CEdit(1).Enabled = False
CEdit(0).Enabled = True
Else
SelCombo.ListIndex = 0
End If
End If
Exit Sub
End If
Next i
'验证字符串长度
Length = -1
For i = 0 To SelCombo.ListCount
If i = ComboListIndex(SelCombo.Index) And Index = 1 Then
Length = Length + Len(Trim(SelCombo.Text)) + 1
Else
Length = Length + Len(SelCombo.List(i)) + 1
End If
Next i
If Length > 255 Then
MsgBox "错误：" & vbCrLf & "当前记录长度为" & Length & "，已超过最大限定值，当前操作无法进行！ ", vbCritical, Me.Caption
GoTo CEdit_ErrorLoop0
End If
'验证字符串的合法性
Select Case SelCombo.Index
Case 1:
If Not IsPhoneNumber(SelCombo.Text) Then
MsgBox "错误：" & vbCrLf & "你输入不是一个合法的电话号码，请重验证后再输入！ ", vbCritical, Me.Caption
CEdit_ErrorLoop0:
SelCombo.SetFocus
SelCombo.SelStart = 0
DoEvents
SelCombo.SelLength = Len(SelCombo.Text)
Exit Sub
End If
Case 2, 3:
If Not IsEmail(SelCombo.Text) Then
MsgBox "错误：" & vbCrLf & "你输入不是一个合法的Email地址，请重验证后再输入！ ", vbCritical, Me.Caption
SelCombo.SetFocus
SelCombo.SelStart = 0
DoEvents
SelCombo.SelLength = Len(SelCombo.Text)
Exit Sub
End If
' Case 4, 5:
' If Not IsLongNUM(SelCombo.Text) Then
' MsgBox "错误：" & vbCrLf & "你输入不是一个合法的号码，请重验证后再输入！ ", vbCritical, Me.Caption
' SelCombo.SetFocus
' SelCombo.SelStart = 0
' SelCombo.SelLength = Len(SelCombo.Text)
' Exit Sub
' End If
End Select
Select Case Index
Case 0: '如果是添加条目
SelCombo.AddItem Trim(SelCombo.Text)
ComboListIndex(SelCombo.Index) = SelCombo.ListCount - 1
Case 1: '如果是编辑条目
SelCombo.List(ComboListIndex(SelCombo.Index)) = Trim(SelCombo.Text)
SelCombo.ListIndex = ComboListIndex(SelCombo.Index)
End Select
SelCombo.SetFocus
End Sub
Private Sub CImage_Click(Index As Integer)
Dim FileNames() As String, UserImage As StdPicture
On Error Resume Next
If (LT1.Visible And (Index = 0)) Or Index = 1 Then
'新增或是修改图片
FileNames = GetOpenFileName(Me.hwnd, App.hInstance, vbNullString, _
"Picture Files|*.JPG;*.BMP;*.GIF;*.ICON;*.JPEG|All Files |*.*|", _
"请选择用户相片文件：", , _
OFN_ENABLESIZING Or OFN_EXPLORER Or OFN_READONLY Or OFN_OVERWRITEPROMPT Or OFN_NOVALIDATE Or OFN_ENABLESIZING)
If Val(FileNames(0)) Then
Set UserImage = LoadPicture(FileNames(1)) '检测是否为正确的图片文件
If Not (UserImage Is Nothing) Then
If UserImage.Width Then
'将图片保存到数据库
StatusBar1.Panels(4).Text = sBar(2) '提示正在保存图片到数据库
If EditIndex = -1 Then TB1_ButtonClick TB1.Buttons("tSave")
Set UserImage = Nothing
If EditIndex > 0 Then
If SaveImage(EditIndex, FileNames(1)) Then '保存图片成功
PBox.Cls
DisposeImage
LoadImage FileNames(1), False
ShowImage PBox.hdc, PBox.ScaleWidth, PBox.ScaleHeight
PBox.Refresh
If Index = 0 Then '修改CImage按钮属性
CImage(0).Enabled = False
CImage(1).Enabled = True
CImage(2).Enabled = True
LT1.Visible = False
End If
End If
End If
StatusBar1.Panels(4).Text = sBar(1) '重新设置提示信息
End If
Else '加载图片出错
MsgBox "错误(读取图片文档失败)：" & vbCrLf & " 文档 '" & FileNames(1) & "' 不是有效的图片文件 " & vbCrLf & "或是当前版本不支持此类图片文档！ ", vbCritical Or vbOKOnly, Me.Caption
End If
End If
Else
'删除数据库中的图片
StatusBar1.Panels(4).Text = sBar(2) '提示正在修改数据库
DelImage EditIndex '删除图片
StatusBar1.Panels(4).Text = sBar(1) '重新设置提示信息
PBox.Cls '清除相片框中的图片
LT1.Caption = "暂无图片"
'修改CImage按钮属性
LT1.Visible = True
CImage(0).Enabled = True
CImage(1).Enabled = False
CImage(2).Enabled = False
End If
End Sub
Private Sub Combo1_Change(Index As Integer)
Dim Bytes() As Byte, i As Long, STR1 As String, j As Long, S As Long
Static Flag As Boolean, Nums As Integer
If Flag Then Exit Sub
Nums = 0
On Error Resume Next
If EditIndex = 0 Then
Flag = True
Combo1(Index).ListIndex = ComboListIndex(Index)
Flag = False
Exit Sub
End If
TB1.Buttons("tSave").Enabled = True
Select Case Index
Case 1 To 5:
If Len(Combo1(Index).Text) = 0 Or Combo1(Index).Style = 1 Then
For i = 0 To 2
CEdit(i).Enabled = False
CEdit(0).Enabled = True: CEdit(1).Enabled = False: CEdit(2).Enabled = False
Next i
Exit Sub
End If
' CEdit(0).Enabled = True: CEdit(1).Enabled = True: CEdit(2).Enabled = False
S = Combo1(Index).SelStart
Bytes() = StrConv(Combo1(Index).Text, vbFromUnicode)
Do
Select Case Bytes(i)
Case &H30 To &H39: '"0"～"9"直接通过
i = i + 1
Case 45: '处理"-"号
If (Index < 1) Or (Index > 3) Or i = 0 Then
GoTo Combo1_C_LOOP1
ElseIf Bytes(i - 1) = 45 Then
GoTo Combo1_C_LOOP1
Else
i = i + 1
End If
Case 46, 64: '处理"."和"@"号
If (Nums > 0 And Bytes(i) = 64) Or (Index < 2) Or (Index > 3) Or (i = 0) Then
GoTo Combo1_C_LOOP1
ElseIf Bytes(i - 1) = 46 Then
GoTo Combo1_C_LOOP1
Else
i = i + 1
Nums = 1
End If
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -