📄 pldel.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{0D452EE1-E08F-101A-852E-02608C4D0BB4}#2.0#0"; "FM20.DLL"
Begin VB.Form PLDEL
BackColor = &H00FFC0C0&
Caption = "批量删除联系人"
ClientHeight = 8700
ClientLeft = 60
ClientTop = 450
ClientWidth = 12015
LinkTopic = "Form1"
MaxButton = 0 'False
MDIChild = -1 'True
ScaleHeight = 8700
ScaleWidth = 12015
Begin VB.TextBox Text1
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 330
Left = 5235
TabIndex = 6
Top = 465
Width = 2070
End
Begin VB.ComboBox Combo1
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 1620
TabIndex = 5
Text = "所有项目"
Top = 480
Width = 2085
End
Begin VB.CommandButton Command4
Caption = "全部取消"
Height = 570
Left = 3825
TabIndex = 4
Top = 7590
Width = 1725
End
Begin VB.CommandButton Command3
Caption = "退出"
Height = 555
Left = 9240
TabIndex = 3
Top = 7620
Width = 1920
End
Begin VB.CommandButton Command2
Caption = "删除选中联系人"
Height = 570
Left = 6585
TabIndex = 2
Top = 7590
Width = 1980
End
Begin VB.CommandButton Command1
Caption = "全选"
Height = 570
Left = 1035
TabIndex = 1
Top = 7605
Width = 1725
End
Begin MSComctlLib.ListView lv
Height = 6120
Left = 930
TabIndex = 0
Top = 1170
Width = 10260
_ExtentX = 18098
_ExtentY = 10795
View = 3
LabelEdit = 1
MultiSelect = -1 'True
LabelWrap = -1 'True
HideSelection = -1 'True
Checkboxes = -1 'True
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
Icons = "ImageList1"
SmallIcons = "ImageList1"
ColHdrIcons = "ImageList1"
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin MSComctlLib.ImageList ImageList1
Left = 0
Top = 0
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 32
ImageHeight = 32
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 1
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "PLDEL.frx":0000
Key = ""
EndProperty
EndProperty
End
Begin VB.Label Label2
BackStyle = 0 'Transparent
Caption = "条件"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 285
Left = 915
TabIndex = 9
Top = 510
Width = 630
End
Begin VB.Label Label3
BackStyle = 0 'Transparent
Caption = "关键字"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 285
Left = 4350
TabIndex = 8
Top = 525
Width = 945
End
Begin MSForms.CommandButton cmd_CZ
Height = 405
Left = 8115
TabIndex = 7
Top = 480
Width = 1290
VariousPropertyBits= 19
Caption = "检索"
Size = "2275;714"
FontName = "宋体"
FontHeight = 180
FontCharSet = 134
FontPitchAndFamily= 34
ParagraphAlign = 3
End
Begin VB.Shape Shape1
BorderColor = &H00FFFFFF&
Height = 8415
Left = 570
Top = 90
Width = 10965
End
End
Attribute VB_Name = "PLDEL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Combo1_click()
Text1.SetFocus
End Sub
Private Sub Text1_gotfocus()
Text1.IMEMode = 1
End Sub
Private Sub Text1_keypress(KeyAscii As Integer)
If KeyAscii = 13 Then
cmd_CZ_Click
End If
End Sub
Private Sub cmd_CZ_Click()
On Error GoTo err
lv.ListItems.clear
'-----------------------------当查询条件为“所有项目时"
If Combo1 = "所有项目" Then
Me.lv.ListItems.clear '先清空listview
Call OpenConn
sql = "select * from 联系人档案"
rs.Open sql, cn, 3, 3
For i = 0 To rs.Fields.Count - 1
xmmc = rs.Fields(i).Name
Call OpenConn1
sql1 = "select * from 联系人档案 where " & xmmc & " like '%" & Text1 & "%'"
rs1.Open sql1, cn1, 3, 3
If rs1.RecordCount > 0 Then
Do While Not rs1.EOF
Set Item = lv.FindItem(rs1.Fields("编号"), , , lvwPartial) '判断是否是重复客户
If Item Is Nothing Then
it = 1
Else
it = 0
End If
If it = 1 Then
Set addlist = lv.ListItems.add(, , IIf(IsNull(rs1.Fields(rs1.Fields(0).Name)), "", rs1.Fields(rs1.Fields(0).Name)), , 1)
For h = 1 To rs1.Fields.Count - 1
addlist.SubItems(h) = IIf(IsNull(rs1.Fields(rs1.Fields(h).Name)), "", rs1.Fields(rs1.Fields(h).Name))
Next h
End If
rs1.MoveNext
Loop
End If
Call CloseConn1
Next i
Call CloseConn
Exit Sub
End If
'-----------------------------当查询条件不为“所有项目时"
Call OpenConn
sql = "select * from 联系人档案 where " & Combo1 & " like '%" & Text1 & "%'"
rs.Open sql, cn, 3, 3
If rs.RecordCount > 0 Then
Do While Not rs.EOF
Set addlist = lv.ListItems.add(, , IIf(IsNull(rs.Fields(rs.Fields(0).Name)), "", rs.Fields(rs.Fields(0).Name)), , 1)
For u = 1 To rs.Fields.Count - 1
addlist.SubItems(u) = IIf(IsNull(rs.Fields(rs.Fields(u).Name)), "", rs.Fields(rs.Fields(u).Name))
Next u
rs.MoveNext
Loop
End If
err:
If err.Description <> "" Then
MsgBox "操作错误，请检查你的查询条件", vbOKOnly, "提示"
End If
End Sub
Private Sub Command1_Click()
Dim nitem As ListItem
For n = 1 To lv.ListItems.Count
With lv
.ListItems.Item(n).Checked = True
End With
Next n
End Sub
Private Sub Command2_Click()
Call delxx
ZJM.RefreshList.Value = True
End Sub
Private Sub Command3_Click()
Unload Me
End Sub
Private Sub Command4_Click()
Dim nitem As ListItem
For n = 1 To lv.ListItems.Count
With lv
.ListItems.Item(n).Checked = False
End With
Next n
End Sub
Private Sub Form_Load()
Me.Height = 9210
Me.Width = 12135
Me.Top = Screen.Height / 2 - Me.Height / 2 - 400
Me.Left = Screen.Width / 2 - Me.Width / 2
sql = "select * from 联系人档案"
Call OpenConn
rs.Open sql, cn, 3, 3
Me.lv.ListItems.clear
For i = 0 To rs.Fields.Count - 1
Me.lv.ColumnHeaders.add = rs.Fields(i).Name
Next i
lv.ColumnHeaders(1).Width = 800
If rs.RecordCount > 0 Then
Do While Not rs.EOF
Set addlist = lv.ListItems.add(, , IIf(IsNull(rs.Fields(rs.Fields(0).Name)), "", rs.Fields(rs.Fields(0).Name)), , 1)
For k = 1 To rs.Fields.Count - 1
addlist.SubItems(k) = IIf(IsNull(rs.Fields(rs.Fields(k).Name)), "", rs.Fields(rs.Fields(k).Name))
Next k
rs.MoveNext
Loop
End If
Call CloseConn
'----------------------设置前六列列宽
lv.ColumnHeaders(1).Width = 800
lv.ColumnHeaders(2).Width = 800
lv.ColumnHeaders(3).Width = 800
lv.ColumnHeaders(4).Width = 1000
lv.ColumnHeaders(5).Width = 1600
lv.ColumnHeaders(6).Width = 1600
lv.ColumnHeaders(7).Width = 800
lv.ColumnHeaders(8).Width = 1600
'----------------------加载可选查询条件
Combo1.AddItem "所有项目"
sql = "select * from 联系人档案"
Call OpenConn
rs.Open sql, cn, 3, 3
For i = 0 To rs.Fields.Count - 1
Combo1.AddItem rs.Fields(i).Name
Next i
Call CloseConn
End Sub
Sub delxx() '删除选中项目过程模块
Dim nCount As Integer
Dim nIndex As Integer
Dim oitem As ListItem
If lv.ListItems.Count = 0 Then
MsgBox "列表中没有可操作的项目！", vbOKOnly, "提示"
Exit Sub
End If
If MsgBox("此操作将删除所有选中项目的联系人信息以及来往记录，是否继续操作？", vbYesNo, "确认删除") = vbNo Then Exit Sub
With lv
nCount = .ListItems.Count
For nIndex = nCount To 1 Step -1
If .ListItems.Item(nIndex).Selected = True Or .ListItems.Item(nIndex).Checked = True Then
'------------------------------------------------------删除对应编号联系人
Call OpenConn
sql = "select * from 联系人档案 where 编号=" & .ListItems.Item(nIndex).Text
rs.Open sql, cn, 3, 3
rs.delete
rs.Update
Call CloseConn
'------------------------------------------------------删除对应编号联系人的来往记录
Call OpenConn
sql = "select * from 来往记录 where 编号='" & .ListItems.Item(nIndex).Text & "'"
rs.Open sql, cn, 3, 3
Do While Not rs.EOF
rs.delete
rs.Update
rs.MoveNext
Loop
Call CloseConn
'------------------------------------------------------列表中删除选中项
.ListItems.Remove nIndex '
End If
Next
End With
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -