如何用VBA自动生成链接表

olderdream2007@

如何用VBA自动生成链接表？

（因为数据源老是变动  所以希望能有一个代码自动生成链接表）

ganlinlao

{:soso_e120:}直接抄一段给你。顺便赚点小分
'首先 , 作如下测试工作:

  '新建空白 Access 数据库 (.mdb) 文件,

  '并添加若干类型链接表:

  'dBase 5 (*.dbf)、

  'Microsoft Excel (*.xls)、

  'Microsoft Access (*.mdb;*.mda;*.mde) 等,

  '然后再编写如下 VBA 程序:

  'Delphi、VC 等程序同理也可:

  '引用 Microsoft ActiveX Data Objects 2.x Library

  '引用 Microsoft ADO Ext. 2.x for DDL and Security

  '控件: Form1、Command1、Command2、Command3

  Private Sub Command1_Click() '测试链接表信息

  Dim adoConnection As New ADODB.Connection

  adoConnection.Open "rovider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\LnkTbls.mdbersist Security Info=False;Jet OLEDBatabase Password=123"

  Dim adoCatalog As New ADOX.Catalog

  Set adoCatalog.ActiveConnection = adoConnection

  Dim adoTable As New ADOX.Table

  Set adoTable.ParentCatalog = adoCatalog

  Dim i As Integer

  For Each adoTable In adoCatalog.Tables

  If adoTable.Type = "LINK" Then

  Debug.Print adoTable.Name

  For i = 0 To adoTable.Properties.Count - 1

  Debug.Print " " & adoTable.Properties.Item(i).Name & ": " & adoTable.Properties.Item(i).Value

  Next i

  Debug.Print VBA.vbCrLf

  End If

  Next adoTable

  End Sub

  '编程添加链接表

  Private Sub Command2_Click()

  Dim adoConnection As New ADODB.Connection

  adoConnection.Open "rovider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\LnkTbls.mdb;Persist Security Info=False;Jet OLEDBatabase Password=123"

  Dim adoCatalog As New ADOX.Catalog

  Dim adoTable As New ADOX.Table

  'Access

  Set adoCatalog.ActiveConnection = adoConnection

  Set adoTable.ParentCatalog = adoCatalog

  adoTable.Properties.Item("Jet OLEDBink Datasource").Value = "e:\nwind2kpwd.mdb"

  adoTable.Properties.Item("Jet OLEDB:Remote Table Name").Value = "产品"

  adoTable.Properties.Item("Jet OLEDB:Create Link").Value = True

  adoTable.Properties.Item("Jet OLEDBink Provider String").Value = "MS Access;Pwd=456"

  adoTable.Name = "Access"

  adoCatalog.Tables.Append adoTable

  adoConnection.Close

  'dBase

  adoConnection.Open

  Set adoCatalog.ActiveConnection = adoConnection

  Set adoTable.ParentCatalog = adoCatalog

  adoTable.Properties.Item("Jet OLEDBink Datasource").Value = "E:\Borland\Shared\Data"

  adoTable.Properties.Item("Jet OLEDB:Remote Table Name").Value = "animals#dbf"

  adoTable.Properties.Item("Jet OLEDB:Create Link").Value = True

  adoTable.Properties.Item("Jet OLEDB:Link Provider String").Value = "dBase 5.0"

  adoTable.Name = "dBase5"

  adoCatalog.Tables.Append adoTable

  adoConnection.Close

  'Excel

  adoConnection.Open

  Set adoCatalog.ActiveConnection = adoConnection

  Set adoTable.ParentCatalog = adoCatalog

  adoTable.Properties.Item("Jet OLEDB:Link Datasource").Value = "E:\Book97.xls"

  adoTable.Properties.Item("Jet OLEDB:Remote Table Name").Value = "Sheet1$"

  adoTable.Properties.Item("Jet OLEDB:Create Link").Value = True

  adoTable.Properties.Item("Jet OLEDB:Link Provider String").Value = "Excel 5.0;HDR=NO;IMEX=2"

  adoTable.Name = "Excel"

  adoCatalog.Tables.Append adoTable

  adoConnection.Close

  '...

  End Sub

  '编程删除链接表

  Private Sub Command3_Click()

  Dim adoConnection As New ADODB.Connection

  adoConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\LnkTbls.mdb;Persist Security Info=False;Jet OLEDBatabase Password=123"

  Dim adoCatalog As New ADOX.Catalog

  Set adoCatalog.ActiveConnection = adoConnection

  Dim j As Integer

  Dim i As Integer

  For i = adoCatalog.Tables.Count To 1 Step -1

  If adoCatalog.Tables.Item(i - 1).Type = "LINK" Then

  Debug.Print adoCatalog.Tables.Item(i - 1).Name

  For j = 0 To adoCatalog.Tables.Item(i - 1).Properties.Count - 1

  Debug.Print " " & adoCatalog.Tables.Item(i - 1).Properties.Item(j).Name & ": " & adoCatalog.Tables.Item(i - 1).Properties.Item(j).Value

  Next j

  Debug.Print VBA.vbCrLf

  If VBA.MsgBox("Delete link table [" & adoCatalog.Tables.Item(i - 1).Name & "]?", vbYesNo) Then

  adoCatalog.Tables.Delete adoCatalog.Tables.Item(i - 1).Name

  End If

  End If

  Next i

  End Sub

  Private Sub Command4_Click()

  Dim adoConnection As New ADODB.Connection

  adoConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\LnkTbls.mdb;Persist Security Info=False;Jet OLEDB:Database Password=123"

  Dim adoCatalog As New ADOX.Catalog

  Set adoCatalog.ActiveConnection = adoConnection

  adoCatalog.Tables.Item("Excel").Properties.Item("Jet OLEDB:Link Provider String").Value = "Excel 5.0;HDR=yes;IMEX=2"

  End Sub

  Private Sub Form_Load()

  Command1.Caption = "链接表信息"

  Command2.Caption = "添加链接表"

  Command3.Caption = "删除链接表"

  Command4.Caption = "刷新链接表"

  End Sub

olderdream2007@

谢谢高人指点 不过觉得好复杂呀 呵呵 能不能有简单点的