Listview 的运用

一指禅62

动态生成相应控件

1. Private Sub ControlAdd(ByVal Index As Integer, ByVal Name As String)
   
2.     Rem  第 Index 组标签+文字框/列表框
   
3.     Dim L, T, Ctl As Control
   
4.     L = 12 + ((Index - 1) Mod 3) * 240
   
5.     T = 12 + (Int((Index - 1) / 3)) * 24
   
6.     Rem 添加标签
   
7.     With Me.Frame1.Controls.Add("Forms.Label.1", "xLbl" & Index, True)
   
8.         .Move L, T + 3, 48, 18
   
9.         .Caption = Name & "："
   
10.     End With
    
11.     Rem 添加文本框或复合框
    
12.     If d.Exists(Name) Then
    
13.         Dim a(), n%, ii%, jj%
    
14.         jj = d.Item(Name)
    
15.         For ii = 2 To UBound(mc)
    
16.             If Trim(mc(ii, jj)) = "" Then Exit For
    
17.             n = n + 1: ReDim Preserve a(1, n)
    
18.             a(1, n) = Trim(mc(ii, jj))
    
19.         Next
    
20.         Set Ctl = Me.Frame1.Controls.Add("Forms.ComboBox.1", "Text" & Index, True)
    
21.         Ctl.List = WorksheetFunction.Transpose(a)
    
22.         Ctl.ShowDropButtonWhen = fmShowDropButtonWhenFocus
    
23.     Else
    
24.         Set Ctl = Me.Frame1.Controls.Add("Forms.TextBox.1", "Text" & Index, True)
    
25.     End If
    
26.     Ctl.Move L + 57, T, 132, 18
    
27.     Ctl.BorderStyle = 1
    
28.     Ctl.BorderColor = &H80000002
    
29.     Ctl.ForeColor = &HC00000
    
30.     Rem  加入集合
    
31.     Col.Add Index
    
32. End Sub

复制代码

李桥贵

一指禅62 发表于 2022-2-19 17:50
动态生成相应控件

谢谢老师！

shenzhenyang

一指禅62 发表于 2022-2-19 17:45
全部设计完成。用动态生成控件的方式，极大简化了代码。

1. Option Explicit
   
2. Option Base 1
   
3. 
   
4. Private WithEvents xLbl As MSForms.Label
   
5. Private WithEvents txtBox As MSForms.TextBox
   
6. Private WithEvents comBox As MSForms.ComboBox
   
7. Private Col As New Collection
   
8. 
   
9. Dim mc, d As Object '基础设置表的自定义名称
   
10. Dim i As Long, j%, x%
    
11. Dim SelItem As MSComctlLib.ListItem
    
12. Dim SelRow As Long  '数据库工作表的当前行
    
13. 
    
14. Private Sub UserForm_Initialize()
    
15.     自定义名称管理
    
16.     With ListView1
    
17.         .FullRowSelect = True  '选择整行
    
18.         .Gridlines = True      '显示格线
    
19.         .LabelEdit = lvwManual '标签不可修改
    
20.         'Set .SmallIcons = ImageList1 '借助ImageList控件图片调整行高
    
21.         .View = lvwReport      '列表型
    
22.         .HideColumnHeaders = False '不隐藏列头
    
23.     End With
    
24.     MultiPage1.Value = 0 '指向基础页
    
25.     Call MultiPage1_Change
    
26. End Sub
    
27. 
    
28. Private Sub 自定义名称管理()
    
29.     mc = Sheet2.Range("A1").CurrentRegion.Value
    
30.     Set d = CreateObject("Scripting.Dictionary")
    
31.     For j = 1 To UBound(mc, 2)
    
32.         d(mc(1, j)) = j     '名称及其列号
    
33.     Next
    
34. End Sub
    
35. 
    
36. Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
    
37.     Me.Controls("Text1").Text = Item
    
38.     For i = 2 To Col.Count
    
39.         Me.Controls("Text" & i).Text = Item.SubItems(i - 1)
    
40.     Next
    
41.     cmd保存.Enabled = False
    
42.     cmd修改.Enabled = True
    
43.     cmd删除.Enabled = True
    
44. End Sub
    
45. 
    
46. Private Sub MultiPage1_Change()
    
47.     Rem 功能：关联对应工作表
    
48.     On Error GoTo Err1 '处理工作表不存在的错误
    
49.     Rem  清除列表数据
    
50.     ListView1.ColumnHeaders.Clear
    
51.     ListView1.ListItems.Clear
    
52.     Rem  获取相应记录
    
53.     xName = MultiPage1.SelectedItem.Caption         '页标签
    
54.     Set Sh = Sheets(xName)                          '工作表
    
55.     Database = Sh.Range("A1").CurrentRegion.Value   '数据记录
    
56.     Frame1.Caption = "  " & xName & "  "
    
57.     If UBound(Database) = 0 Then
    
58.         MsgBox "“" & xName & "表”没有任何数据！", vbCritical, "提示"
    
59.         Exit Sub
    
60.     End If
    
61.     Rem  移除旧有的控件
    
62.     If Col.Count > 0 Then
    
63.         For i = Col.Count To 1 Step -1
    
64.             Me.Frame1.Controls.Remove "Text" & i
    
65.             Me.Frame1.Controls.Remove "xLbl" & i
    
66.         Next
    
67.         Set Col = Nothing
    
68.     End If
    
69.    
    
70.     Rem  加载列表头,添加控件
    
71.     For j = 1 To UBound(Database, 2)
    
72.         ListView1.ColumnHeaders.Add , , Database(1, j)
    
73.         Call ControlAdd(j, Database(1, j))
    
74.     Next
    
75.     Frame1.ScrollHeight = (Int((Col.Count - 1) / 3)) * 36
    
76.     Me.Controls("Text1").Enabled = False
    
77.     Call cmd模糊查询_Click
    
78.     Call cmd新建_Click
    
79.     Exit Sub
    
80. Err1:
    
81.     MsgBox Err.Description, vbExclamation, "错误"
    
82.     Err.Clear
    
83. End Sub
    
84. 
    
85. Private Sub ControlAdd(ByVal Index As Integer, ByVal Name As String)    '第 Index 组标签+文字框/列表框
    
86.     Dim L, T, Ctl As Control
    
87.     L = 12 + ((Index - 1) Mod 3) * 240
    
88.     T = 12 + (Int((Index - 1) / 3)) * 24
    
89.     Rem 添加标签
    
90.     With Me.Frame1.Controls.Add("Forms.Label.1", "xLbl" & Index, True)
    
91.         .Move L, T + 3, 48, 18
    
92.         .Caption = Name & "："
    
93.     End With
    
94.     Rem 添加文本框或复合框
    
95.     If d.Exists(Name) Then
    
96.         Dim a(), n%, ii%, jj%
    
97.         jj = d.Item(Name)
    
98.         For ii = 2 To UBound(mc)
    
99.             If Trim(mc(ii, jj)) = "" Then Exit For
    
100.             n = n + 1: ReDim Preserve a(1, n)
     
101.             a(1, n) = Trim(mc(ii, jj))
     
102.         Next
     
103.         Set Ctl = Me.Frame1.Controls.Add("Forms.ComboBox.1", "Text" & Index, True)
     
104.         Ctl.List = WorksheetFunction.Transpose(a)
     
105.         Ctl.ShowDropButtonWhen = fmShowDropButtonWhenFocus
     
106.     Else
     
107.         Set Ctl = Me.Frame1.Controls.Add("Forms.TextBox.1", "Text" & Index, True)
     
108.     End If
     
109.     Ctl.Move L + 57, T, 132, 18
     
110.     Ctl.BorderStyle = 1
     
111.     Ctl.BorderColor = &H80000002
     
112.     Ctl.ForeColor = &HC00000
     
113.     Rem  加入集合
     
114.     Col.Add Index
     
115. End Sub
     
116. 
     
117. Private Sub 保存记录并显示明细(ByVal myRow As Long)
     
118.     If Trim(Me.Controls("Text2").Text) = "" Then
     
119.         MsgBox "姓名不得为空！", vbExclamation, "提示"
     
120.         Me.Controls("Text2").SetFocus
     
121.         Exit Sub
     
122.     End If
     
123.     ReDim a(1, Col.Count)
     
124.     For i = 1 To Col.Count
     
125.         a(1, i) = Trim(Me.Controls("Text" & i).Text)
     
126.     Next
     
127.     Sheets(xName).Range("A" & myRow).Resize(1, Col.Count) = a
     
128.     Call cmd新建_Click
     
129.     txtFind.Text = ""
     
130.     Call cmd模糊查询_Click
     
131. End Sub
     
132. 
     
133. Private Sub cmd新建_Click()
     
134.     For i = 1 To Col.Count
     
135.         Me.Controls("Text" & i).Text = ""
     
136.     Next
     
137.     Me.Controls("Text1").Text = WorksheetFunction.Max(Sheets(xName).Range("A:A")) + 1
     
138.     cmd保存.Enabled = True
     
139.     cmd修改.Enabled = False
     
140.     cmd删除.Enabled = False
     
141. End Sub
     
142. 
     
143. Private Sub cmd保存_Click()
     
144.     i = Sheets(xName).Range("A65536").End(3).Row + 1
     
145.     Call 保存记录并显示明细(i)
     
146. End Sub
     
147. 
     
148. Private Sub cmd修改_Click()
     
149.     i = ListView1.SelectedItem.Tag
     
150.     If i < 2 Then Exit Sub
     
151.     If MsgBox("您正准备修改 1 条记录。" & vbCrLf & vbCrLf & _
     
152.               "如果单击“是”，将无法撤消修改操作。" & vbCrLf & _
     
153.               "确实要修改这条记录吗？", vbQuestion + vbYesNo, "修改记录") = vbYes Then
     
154.         Call 保存记录并显示明细(i)
     
155.     End If
     
156. End Sub
     
157. 
     
158. Private Sub cmd删除_Click()
     
159.     i = ListView1.SelectedItem.Tag
     
160.     If i < 2 Then Exit Sub
     
161.     If MsgBox("您正准备删除 1 条记录。" & vbCrLf & vbCrLf & _
     
162.               "如果单击“是”，将无法撤消删除操作。" & vbCrLf & _
     
163.               "确实要删除这条记录吗？", vbQuestion + vbYesNo, "删除记录") = vbYes Then
     
164.         Sheets(xName).Rows(i).Delete Shift:=xlUp
     
165.         cmd模糊查询_Click
     
166.     End If
     
167. End Sub
     
168. 
     
169. Private Sub cmd清空列表_Click()
     
170.    Label5.Caption = ""
     
171.    ListView1.ListItems.Clear
     
172.    txtFind = ""
     
173. End Sub
     
174. 
     
175. Private Sub txtFind_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
     
176.    If KeyCode = 13 Then Call cmd模糊查询_Click
     
177. End Sub
     
178. 
     
179. Private Sub cmd模糊查询_Click()
     
180.     Dim Item As MSComctlLib.ListItem
     
181.     ListView1.ListItems.Clear
     
182.     Database = Sh.Range("A1").CurrentRegion.Value   '数据记录
     
183.     If UBound(Database) < 2 Then GoTo Err1
     
184.     For i = 2 To UBound(Database)
     
185.         For j = 1 To UBound(Database, 2)
     
186.             If UCase(Database(i, j)) Like "*" & UCase(txtFind) & "*" Then
     
187.                 Set Item = ListView1.ListItems.Add()
     
188.                 Item.Tag = i
     
189.                 Item.Text = Database(i, 1)
     
190.                 For x = 2 To UBound(Database, 2)
     
191.                     Item.SubItems(x - 1) = Database(i, x)
     
192.                 Next
     
193.                 Exit For
     
194.             End If
     
195.         Next
     
196.     Next
     
197. Err1:
     
198.     Label5.Caption = IIf(UBound(Database) - 1 = 0, "", "在 " & UBound(Database) - 1 & " 条记录中找到 " & ListView1.ListItems.Count & " 个。")
     
199.     cmd保存.Enabled = True
     
200.     cmd修改.Enabled = False
     
201.     cmd删除.Enabled = False
     
202. End Sub
     

复制代码

老师刚刚看了这个窗体很人性化可以自定义，这个表头我想下移2行，代码是修改那个位置的代码，谢谢

qiu521119

一指禅62 发表于 2022-2-19 17:45
全部设计完成。用动态生成控件的方式，极大简化了代码。

厉害了，我的大神还能动态

一指禅62

shenzhenyang 发表于 2022-3-13 23:55
老师刚刚看了这个窗体很人性化可以自定义，这个表头我想下移2行，代码是修改那个位置的代码 ...

最直接的方式是修改数据源

Database = Sh.Range("A1").CurrentRegion.Value   '数据记录

shenzhenyang

一指禅62 发表于 2022-3-14 08:25
最直接的方式是修改数据源

Database = Sh.Range("A1").CurrentRegion.Value   '数据记录

Database = Sh.Range("A3").CurrentRegion.Value   '数据记录
这里改成A3 还是不行，

李桥贵

一指禅62 发表于 2022-3-14 08:25
最直接的方式是修改数据源

Database = Sh.Range("A1").CurrentRegion.Value   '数据记录

请问一指禅62老师：
日期从工作表中提取到窗体中时候变成日期+星期
例如：
在工作表中
2023-4-26
到窗体中变成
2023-4-26 星期三
如何避免
谢谢！

一指禅62

李桥贵 发表于 2023-4-26 19:52
请问一指禅62老师：
日期从工作表中提取到窗体中时候变成日期+星期
例如：

以前我好像探讨过这个问题，按这个方法您试试看。


第一步：




第二步：

李桥贵

一指禅62 发表于 2023-4-26 20:11
以前我好像探讨过这个问题，按这个方法您试试看。

老师按您说的已经解决了问题，谢谢您老师！

一指禅62

李桥贵 发表于 2023-4-26 21:43
老师按您说的已经解决了问题，谢谢您老师！

我最早是发现在SQL中，长日期是文本格式，导致SQL语句出问题。所以记住它了。