📄 frmtmsz.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmTMSZ
BorderStyle = 1 'Fixed Single
Caption = "组成员设置"
ClientHeight = 6375
ClientLeft = 2595
ClientTop = 825
ClientWidth = 10185
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6375
ScaleWidth = 10185
Begin VB.TextBox Text1
BackColor = &H8000000F&
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1335
Left = 4920
Locked = -1 'True
MultiLine = -1 'True
TabIndex = 6
Text = "frmTMSZ.frx":0000
Top = 4440
Width = 5175
End
Begin VB.TextBox txtName
Height = 375
Left = 5880
Locked = -1 'True
TabIndex = 4
Top = 7440
Width = 1395
End
Begin VB.CommandButton Command1
Caption = "返回"
Height = 435
Left = 8760
TabIndex = 3
Top = 5880
Width = 1275
End
Begin MSComctlLib.ListView LV3
Height = 2115
Left = 4860
TabIndex = 2
Top = 1800
Width = 5295
_ExtentX = 9340
_ExtentY = 3731
View = 3
LabelWrap = -1 'True
HideSelection = -1 'True
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 4
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "帐本"
Object.Width = 2540
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "编号"
Object.Width = 2540
EndProperty
BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 2
Text = "姓名"
Object.Width = 2540
EndProperty
BeginProperty ColumnHeader(4) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 3
Text = "入会时间"
Object.Width = 2540
EndProperty
End
Begin MSComctlLib.ListView LV2
Height = 4335
Left = 60
TabIndex = 1
Top = 1440
Width = 4755
_ExtentX = 8387
_ExtentY = 7646
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = -1 'True
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin MSComctlLib.ImageList ImageList1
Left = 660
Top = 3540
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 48
ImageHeight = 48
MaskColor = 16777215
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 1
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTMSZ.frx":0051
Key = ""
EndProperty
EndProperty
End
Begin MSComctlLib.ListView Lv1
Height = 1395
Left = 0
TabIndex = 0
Top = 0
Width = 10155
_ExtentX = 17912
_ExtentY = 2461
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
Icons = "ImageList1"
ForeColor = -2147483640
BackColor = -2147483644
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "成员列表"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C00000&
Height = 240
Left = 6780
TabIndex = 7
Top = 1560
Width = 960
End
Begin VB.Label Label1
Caption = "说 明"
BeginProperty Font
Name = "宋体"
Size = 15.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 375
Left = 6720
TabIndex = 5
Top = 4080
Width = 1455
End
End
Attribute VB_Name = "frmTMSZ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private M_Client As Long
Dim TMBH As Long '同名编号
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_GotFocus()
Dim Rs As Recordset
Set Rs = GetRecord("SELECT 帐本编号,帐本 From 帐本表")
RSToListView Rs, LV1, False
End Sub
Private Sub Form_Initialize()
InitCommonControls
End Sub
Private Sub Form_Load()
DeleteTm '删除冗余的同名
Dim Rs As Recordset
Set Rs = GetRecord("SELECT 帐本编号,帐本 From 帐本表")
RSToListView Rs, LV1, False
End Sub
Private Sub HFG_DblClick()
Dim R As Integer
Dim Id As Integer
'Dim C As Integer
R = HFG.Row
HFG.Col = 0
Id = HFG.Text
'MsgBox ID
End Sub
Private Sub lstGK_DblClick()
End Sub
Private Sub Form_Resize()
On Error Resume Next
'Frame1.Width = Me.Width - Frame1.Left * 3
End Sub
Private Sub Lv1_ItemClick(ByVal Item As MSComctlLib.ListItem)
Dim SQL As String
Dim i As Integer
Dim ZB As Integer
ZB = Val(VBA.Mid(Item.Key, 4))
Find "所在帐本=" & ZB
End Sub
Private Sub LV2_DblClick()
If LV2.ListItems.Count > 0 Then
If LV2.SelectedItem.Index > 0 Then
AddTOLv3
End If
End If
End Sub
Private Sub LV2_ItemClick(ByVal Item As MSComctlLib.ListItem)
'MsgBox ""
End Sub
Private Sub LV3_DblClick()
If LV3.ListItems.Count > 0 Then
If LV3.SelectedItem.Index > 0 Then
Dim Id As String
Id = Mid(LV3.SelectedItem.Key, 4)
LV3.ListItems.Remove (LV3.SelectedItem.Index)
RemoveTM CLng(Id)
End If
End If
End Sub
Private Sub Option1_Click()
SetCXTJ
End Sub
Private Sub Option2_Click()
SetCXTJ
End Sub
Private Sub txtBn_Change()
Dim sel As Integer
sel = Val(txtBn)
If sel > 0 Then
If sel <= LV1.ListItems.Count Then
LV1.ListItems(sel).Selected = True
End If
End If
End Sub
Private Sub txtXm_GotFocus()
'Command1.Default = True
End Sub
Private Sub txtXm_LostFocus()
'Command1.Default = False
End Sub
Private Sub SetCXTJ()
If Option1.Value = True Then
txtXm.Enabled = True
txtBh.Enabled = False
Else
txtXm.Enabled = False
txtBh.Enabled = True
End If
End Sub
Sub Find(Optional ByVal Con As String = "", Optional ByVal blFind As Boolean = False)
Dim Rs As Recordset
Dim SQL As String
'主SQL语句
SQL = "SELECT 客户编号,编号,客户名称,入会时间 from 客户表"
SQL = SQL & " WHERE 1=1"
'blFind参数代表是否从上面查找
If blFind = True Then
If cboZb.ListIndex > 0 Then
SQL = SQL & " AND 所在帐本=" & cboZb.ItemData(cboZb.ListIndex)
End If
End If
If Con <> "" Then
SQL = SQL & " AND " & Con
End If
'SQL = SQL & " AND 入会时间>#" & GetBeginDate & "#"
SQL = SQL & " Order by 编号"
Set Rs = GetRecord(SQL)
LV2.ListItems.Clear
LV2.ColumnHeaders.Clear
RSToListView2 Rs, LV2
End Sub
'这个过程的功能是把记录集的内容显示在ListView上
Private Sub RSToListView(objRs As Recordset, LV As ListView, ByVal withTitle As Boolean)
Dim i As Long
Dim j As Long
Dim K As Long
LV1.ListItems.Clear
If objRs.State <> 0 Then
If Not (objRs.EOF And objRs.BOF) Then
Do While Not objRs.EOF
LV.ListItems.Add , "Key" & objRs.Fields(0).Value, objRs.Fields(1).Value, 1
objRs.MoveNext
Loop
End If
End If
End Sub
Private Sub AddZbToList()
End Sub
Private Sub AddTOLv3()
Dim ZB As String
Dim i As Integer
Dim Ct As Long
Dim Id As Long
Id = CLng(Right(LV2.SelectedItem.Key, Len(LV2.SelectedItem.Key) - 3))
For i = 1 To LV3.ListItems.Count
If LV3.ListItems(i).Key = LV2.SelectedItem.Key Then Exit Sub
Next
ZB = LV1.SelectedItem.Text
LV3.ListItems.Add , LV2.SelectedItem.Key, ZB
Ct = LV3.ListItems.Count
LV3.ListItems.Item(Ct).SubItems(1) = LV2.SelectedItem.Text
LV3.ListItems.Item(Ct).SubItems(2) = LV2.SelectedItem.SubItems(1)
LV3.ListItems.Item(Ct).SubItems(3) = LV2.SelectedItem.SubItems(2)
If TMBH = 0 Then
CreateTM
'AddTM Id
Else
If Id <> M_Client Then
AddTM Id
End If
End If
End Sub
Private Sub RemoveFromLV3(ByVal sKey As String)
Dim i As Long
For i = 1 To LV3.ListItems.Count
If LV3.ListItems(i).Key = sKey Then
LV3.ListItems.Remove i
End If
Next
End Sub
Public Property Get ClientID() As Long
ClientID = M_Client
End Property
Public Property Let ClientID(ByVal vNewValue As Long)
M_Client = vNewValue
Dim SQL As String
Dim Rs As Recordset
Dim Tmp As Variant
txtName = CStr(GetValue("SELECT 客户名称 FROM 客户表 WHERE 客户编号=" & M_Client))
SQL = "SELECT 同名编号 FROM 成员表 Where 客户编号=" & M_Client
Tmp = GetValue(SQL)
TMBH = CLng(Tmp)
If TMBH <= 0 Then '没有查到同名
'Label1.Caption = "暂时没有和" & txtName.Text & "同名的客户！"
Exit Property
Else
SQL = "SELECT 客户编号,帐本,编号,客户名称,入会时间 FROM 同名明细表 Where 同名编号=" & TMBH
Set Rs = GetRecord(SQL)
RSToListView2 Rs, LV3
End If
End Property
Private Function CreateTM() As Long '新建同名列表
Dim Tmp As String
Dim SQL As String
Dim TMP2 As Variant
CheckSQL Tmp
SQL = "Insert Into 同名表(备注) VALUES('" & Tmp & "')"
ExecSQL SQL
SQL = "SELECT MAX(同名编号) FROM 同名表"
TMP2 = GetValue(SQL)
TMBH = CLng(TMP2)
If TMBH > 0 Then
SQL = "Insert Into 成员表(同名编号,客户编号) VALUES(" & TMBH & "," & M_Client & ")"
ExecSQL SQL
Else
MsgBox "无法建立同名列表!"
End If
CreateTM = TMBH
End Function
Private Sub AddTM(ByVal KH As Long)
Dim SQL As String
SQL = "Insert Into 成员表(同名编号,客户编号) VALUES(" & TMBH & "," & KH & ")"
ExecSQL SQL
End Sub
Private Sub RemoveTM(ByVal KH As Long)
Dim SQL As String
SQL = "DELETE FROM 成员表 WHERE 客户编号=" & KH
ExecSQL SQL
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -