基於VB6+ADO+ListView製作的一個資料庫分頁顯示程式（完整原程式） (轉)

基於VB6+ADO+ListView製作的一個資料庫分頁顯示程式（完整原程式） (轉)[@more@]

資料顯示演示，在透過，詳細請自行進行學習測試，程式大小29K

完整原程式下載地址:/lshdic/vb_adoread.zip">

程式碼瀏覽：

Dim link1 As New ADO.Connection
Dim rs As New ADODB.Recordset
Dim page As Integer
Dim pubdatapath As String

Sub opendatabase(datapath As String)  '開啟資料庫
page = 1  '首次定義開啟時的頁碼為1
If link1.State = 1 Then  '如果以連線過，則關閉，初始化下次事務
link1.Close: list2.ListItems.Clear: list2.ColumnHeaders.Clear: c.Clear: list1.ListItems.Clear
End If
link1.ConnectionString = "Provr=.jet.oledb.4.0;data =" & datapath
link1.Open
pubdatapath = datapath
Set biaoming = link1.OpenSchema(adSchemaColumns)  '建立資料庫記錄集
tablename = ""
Do Until biaoming.EOF
If biaoming("table_name") <> tablename Then  '列出所有表
tablename = biaoming("table_name")
list1.ListItems.Add , , tablename
End If
biaoming.MoveNext
L
Set biaoming = Nothing
menu1.Enabled = True
list1_MouseUp 1, 0, 10, 10
End Sub
Private Sub Command1_Click()  '開啟資料庫
d.DialogTitle = "開啟一個資料庫進行瀏覽"
d.InitDir = App.Path
d.FileName = ""
d.Filter = "Access資料庫(mdb字尾,推薦格式)|*.mdb"
d.ShowOpen
If d.FileName = "" Then Exit Sub
opendatabase d.FileName
End Sub

Private Sub Command4_Click()
str1 = InputBox("請輸入一個1-5000之間的數字", "重設", Text1.Text)
If str1 = Text1.Text Or str1 = "" Then Exit Sub
If IsNumeric(str1) = False Then Exit Sub
If str1 > 5000 Or str1 < 1 Then Exit Sub
Text1.Text = str1
If list1.ListItems.Count = 0 Then Exit Sub Else list1_MouseUp 1, 0, 10, 10
End Sub

Private Sub down_Click()  '功能，下一頁
page = page + 1: list1_MouseUp 1, 0, 10, 10
End Sub

Private Sub findstr_Click()  '查詢資料
If InStr(Text2.Text, "'") <> 0 Then MsgBox "查詢時關鍵字不允許包含 ' 符號", vbCritical, "無效字元": Exit Sub
If rs.State = 1 Then rs.Close
rs.Open " " & c.Text & " from " & list1.SelectedItem.Text & " where " & c.Text & " like '%" & Text2.Text & "%'", link1, adOpenStatic, adLockReadOnly
If rs.EOF Then MsgBox "沒有符號條件的記錄,請從新查詢", vbCritical, "未發現記錄": Exit Sub
Do While Not rs.EOF
i = i + 1
str1 = str1 & i & " ： " & rs(0) & vbCrLf
rs.MoveNext
Loop
MsgBox str1, vbExclamation, "查詢結果 - " & rs.RecordCount & "匹配"
End Sub

Private Sub Form_Resize()
list1.ColumnHeaders(1).Width = list1.Width - 80
list2.Width = Me.ScaleWidth - list2.Left - 30
list1.Height = Me.ScaleHeight - list1.Top - 30
list2.Height = Me.ScaleHeight - (Me.ScaleHeight - down.Top) - 150
End Sub

Private Sub Form_Unload(Cancel As Integer)
If rs.State = 1 Then rs.Close
If link1.State = 1 Then link1.Close
Set rs = Nothing: Set link1 = Nothing
End Sub

Private Sub list1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)  '切換表
On Error Resume Next
If list1.ListItems.Count = 0 Then Exit Sub
If rs.State = 1 Then rs.Close
list2.ListItems.Clear: list2.ColumnHeaders.Clear: c.Clear
rs.Open "select * from " & list1.SelectedItem.Text, link1, adOpenStatic, adLockReadOnly
If Err.Number <> 0 Then
MsgBox "該資料表不能支援的遊標", vbCritical, "不規則的格式": Exit Sub
End If
rs.PageSize = Text1.Text
rslen = rs.RecordCount
If rs.PageCount < page Then page = 1
Label3.Caption = "共" & rslen & "條記錄,共" & rs.PageCount & "頁,當前頁碼 " & page
If rs.PageCount > page Then down.Enabled = True Else down.Enabled = False
If page <> 1 Then up.Enabled = True Else up.Enabled = False
Set ziduan = rs.Fields  '定義欄位記錄集
For i = 0 To ziduan.Count - 1
list2.ColumnHeaders.Add , , ziduan(i).Name  '根據欄位指定檢視列
c.AddItem ziduan(i).Name
rs.MoveFirst  '記錄到尾後填充下一列
rs.AbsolutePage = page  '定義記錄集的絕對頁碼
For r = 0 To rs.PageSize - 1
If rs.EOF Then Exit For
rstext = rs(i)
If i = 0 Then  '首次直接填充第一列
list2.ListItems.Add , , rstext
Else  '非首次填充下一下
If rstext <> Empty Then list2.ListItems(r + 1).ListSubItems.Add , , rstext Else list2.ListItems(r + 1).ListSubItems.Add , , ""
End If
rs.MoveNext
Next
Next
If c.ListCount <> 0 Then c.ListIndex = 0: findstr.Enabled = True Else findstr.Enabled = False
Set ziduan = Nothing
End Sub

Private Sub menu01_Click(Index As Integer)
Select Case Index
Case 1:  '建新表演示
str1 = 1
For i = 1 To list1.ListItems.Count
If InStr(list1.ListItems(i).Text, "新建表") = 1 Then str1 = str1 + 1
Next
link1.Execute "create table 新建表" & str1 & "(會員名 Text,密碼 Varchar(8),年齡 int not null,值 " & _
"integer,加入日期 DateTime null)"
link1.Execute "insert into 新建表" & str1 & "(會員名,密碼,年齡,經驗值,加入日期) values ('風雲舞','12345678'" & _
",18,365,'" & Now & "')"
link1.Execute "insert into 新建表" & str1 & "(會員名,密碼,年齡,經驗值,加入日期) values ('Lshdic','87654321'" & _
",18,365,'" & Now & "')"
opendatabase pubdatapath  '重新整理重灌載列表
Case 2:  '重新整理——重灌載
opendatabase pubdatapath
Case 3:  '刪除
If rs.State = 1 Then rs.Close
link1.Execute "Drop table " & list1.SelectedItem.Text
opendatabase pubdatapath
Case 4:  '表屬性
If rs.State = 1 Then rs.Close
rs.Open "select * from " & list1.SelectedItem.Text, link1, adOpenStatic, adLockReadOnly
For i = 0 To rs.Fields.Count - 1
str1 = str1 & rs.Fields(i).Name & ","
str2 = str2 & rs.Fields(i).Type & ","
str3 = str3 & rs.Fields(i).ActualSize & ","
str4 = str4 & rs.Fields(i).DefinedSize & ","
Next
MsgBox "包含欄位:" & str1 & vbCrLf & vbCrLf & "欄位型別:" & str2 & vbCrLf & vbCrLf & "第一行資料大小:" & _
str3 & vbCrLf & vbCrLf & "每行資料預設容量:" & str4, vbExclamation, "表屬性"
End Select
End Sub

Private Sub Text2_GotFocus()
If Text2.Text = "查詢關鍵字..." Then Text2.Text = ""
End Sub

Private Sub Text2_LostFocus()
If Text2.Text = "" Then Text2.Text = "查詢關鍵字..."
End Sub

Private Sub up_Click()  '功能，上一頁
page = page - 1: list1_MouseUp 1, 0, 10, 10
End Sub