自己编制的，共享一下：

模块1：（代码）

Dim btop
Dim bleft

Public Function GetDatabaseName()
 GetDatabaseName = "DBQ=D:\INETPUB\WWWROOT\jshb\test.mdb;DefaultDir=;DRIVER={Microsoft Access Driver (*.mdb)};"
End Function

Public Sub InitPage()
btop = 4
bleft = 2
End Sub

Public Sub TitleName()
  Cells(btop, bleft) = "id"
  Cells(btop, bleft + 1) = "type"
  Cells(btop, bleft + 2) = "姓名"
  Cells(btop, bleft + 3) = "公司"
  Cells(btop, bleft + 4) = "座机"
  Cells(btop, bleft + 5) = "手机"
  Cells(btop, bleft + 6) = "传真"
  Cells(btop, bleft + 7) = "职位"
  Cells(btop, bleft + 8) = "Email"
End Sub

Public Sub ClearPage()
  Dim addr
  b = btop + 1
  addr = "A" & b & ":Z1000"
  Range(addr).ClearContents
End Sub

Public Sub Serchmdb(ByVal SelectType, ItemContent, ItemName, st As String)
  Dim cmd As String
  Dim oAss As Object
  Dim b
 
  connstr = GetDatabaseName
  Set oAss = CreateObject("ADODB.connection")
  oAss.Open connstr
  If SelectType = "all" Then
    cmd = "SELECT * FROM telephone ORDER BY id DESC"
  Else
    cmd = "SELECT * FROM telephone WHERE " + ItemName + " like " + st + "%" + ItemContent + "%" + st
  End If
  On Error GoTo 0
  Set rs = oAss.Execute(cmd)

  ClearPage
  b = btop + 1
  Do While Not rs.EOF
  Cells(b, bleft) = rs("id")
  Cells(b, bleft + 1) = rs("type")
  Cells(b, bleft + 2) = rs("姓名")
  Cells(b, bleft + 3) = rs("公司")
  Cells(b, bleft + 4) = rs("座机")
  Cells(b, bleft + 5) = rs("手机")
  Cells(b, bleft + 6) = rs("传真")
  Cells(b, bleft + 7) = rs("职位")
  Cells(b, bleft + 8) = rs("Email")
  b = b + 1
  rs.movenext
  Loop
  rs.Close

End Sub

Sheet1：（代码）

Dim ItemName, SelectType As String
Dim Msg, Style, Title, Ctxt, Response

Private Sub Button_Delect_Click()
Dim ii, acomp

ii = TextId.Text
acomp = TextComp.Text
If ii = "" Then
  MsgBox ("ID 不能空")
Else
  Msg = "删除第" + ii + "段数据，确认?" ' 定义信息。
  Response = MsgBox(Msg, Style, Title, Help, Ctxt)
  If Response = vbYes Then    ' 用户按下“是”。
    Deletemdb ii
    Serchmdb "Select", acomp, "公司", "'"
  End If
 
End If
End Sub

Private Sub Button_Search_Click()
Dim ItemContent, st As String
SelectType = "select"
ItemContent = TextBox1.Text
If ItemName = "" Then
  ItemName = ComboBox1.List(0)
End If
If ItemName <> "id" Then
  st = "'"
Else
  st = ""
End If
TitleName
ClearPage
Serchmdb SelectType, ItemContent, ItemName, st
End Sub

Private Sub Button_SelectAll_Click()
Dim ItemContent, st As String
SelectType = "all"
ItemContent = ""
st = ""
Serchmdb SelectType, ItemContent, ItemName, st
End Sub

Private Sub Button_Update_Click()
Dim aid, atype, aname, acomp, ajob, aphone, amobil, afax, aemail As String
atype = TextType.Text
If atype = "" Then
  MsgBox ("Type 不能空白")
Else
  aid = TextId.Text
  aname = TextName.Text
  acomp = TextComp.Text
  ajob = TextJob.Text
  aphone = TextPhone.Text
  amobil = TextMobil.Text
  afax = TextFax.Text
  aemail = TextEmail.Text

  If aid = "" Then
    Addmdb atype, aname, acomp, ajob, aphone, amobil, afax, aemail
  Else
    Msg = "修改第" + aid + "段数据，确认?" ' 定义信息。
    Response = MsgBox(Msg, Style, Title, Help, Ctxt)
    If Response = vbYes Then    ' 用户按下“是”。
      Updatemdb aid, atype, aname, acomp, ajob, aphone, amobil, afax, aemail
    End If
  End If
  Serchmdb "Select", acomp, "公司", "'"
End If
End Sub

Private Sub ComboBox1_Change()
Dim i
i = ComboBox1.ListIndex
If i < 0 Then
  ItemName = ""
Else
  ItemName = ComboBox1.List(i)
End If
End Sub

Private Sub CommandAdd_Click()
TextId.Text = ""
End Sub

Public Sub InitText()
Style = vbYesNo + vbCritical + vbDefaultButton2    ' 定义确认框按钮。
Title = "确认"    ' 定义确认框标题。
Ctxt = 1000    ' 定义确认框标题

TextId.Text = ""
TextType.Text = ""
TextName.Text = ""
TextComp.Text = ""
TextJob.Text = ""
TextPhone.Text = ""
TextMobil.Text = ""
TextFax.Text = ""
TextEmail.Text = ""
End Sub

Public Sub addcom()

With ComboBox1
  .Clear
  '.AddItem Cells(2, 1) '把你数据单元格的数据add到
  '.AddItem Cells(2, 2) '把你数据单元格的数据add到
  '.AddItem Cells(2, 3) '把你数据单元格的数据add到
  .AddItem "姓名"
  .AddItem "公司"
  .AddItem "座机"
  .AddItem "手机"
  .AddItem "传真"
  .AddItem "职位"
  .AddItem "Email"
  .AddItem "type"
  .Text = .List(0)
  si = .List(0)
End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Straddr = Target.Cells(1, 1).Address
Col_s = Mid(Straddr, 2, 1)
Row_n = Mid(Straddr, 4)
If Col_s = "B" And Row_n > 4 Then
  TextId.Text = Cells(Row_n, 2)
  TextType.Text = Cells(Row_n, 3)
  TextName.Text = Cells(Row_n, 4)
  TextComp.Text = Cells(Row_n, 5)
  TextPhone.Text = Cells(Row_n, 6)
  TextMobil.Text = Cells(Row_n, 7)
  TextFax.Text = Cells(Row_n, 8)
  TextJob.Text = Cells(Row_n, 9)
  TextEmail.Text = Cells(Row_n, 10)
End If
End Sub

ThisWorkBook：（代码）

Private Sub Workbook_Open()
Sheet1.addcom
Sheet1.InitText
InitPage
End Sub

评论