导出Access的超链接到Excel

roych

你应该用绝对路径才能处理的。俺还特意录制了下视频供参考

1. '其它说明：
   
2. '1、需要引用Excel 11.0 库。
   
3. '2、超链接应设置为绝对路径（而不是相对路径），详见第二条记录。
   
4. Sub test()
   
5. 
   
6. Dim rst As New ADODB.Recordset
   
7. Dim exl As Excel.Application
   
8. Dim wk As Workbook
   
9. Dim ws As Worksheet
   
10. '打开记录集，并创建Excel控件。
    
11. rst.Open "邮件列表", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    
12. Set exl = CreateObject("Excel.Application")
    
13. '删除旧文件，如出错则跳步。
    
14. On Error Resume Next
    
15. If Dir("D:\邮件列表.xls") Then Kill "D:\邮件列表.xls"
    
16. '创建工作簿，并激活第一个工作表
    
17. Set wk = exl.Workbooks.Add()
    
18. wk.Sheets(1).Activate
    
19. Set ws = wk.ActiveSheet
    
20. '写入表头
    
21. For i = 0 To rst.Fields.Count - 1
    
22.     ws.Range("A1").Offset(0, i) = rst.Fields(i).Name
    
23. Next
    
24. i = 0
    
25. '写入记录内容
    
26. For i = 1 To rst.RecordCount
    
27.     ws.Range("A1").Offset(i, 0) = rst(0)
    
28.     ws.Range("A1").Offset(i, 1) = rst(1)
    
29.     ws.Range("A1").Offset(i, 2) = rst(2)
    
30. '写入超链接公式。请特别留意里面的转义字符写法。
    
31.     ws.Range("A1").Offset(i, 3) = "=hyperlink(""" & Left(rst(3), InStr(1, rst(3), "#")) & """,""" & Left(rst(3), InStr(1, rst(3), "#") - 1) & """)"
    
32.     ws.Range("A1").Offset(i, 4) = rst(4)
    
33.     rst.MoveNext
    
34. Next
    
35. '关闭记录集，保存数据后关闭电子表格。
    
36. rst.Close
    
37. Set rst = Nothing
    
38. wk.SaveAs "D:\邮件列表.xls"
    
39. wk.Close
    
40. MsgBox "数据已成功导出到：D:\邮件列表.xls"
    
41. End Sub

复制代码