通用数据链接文件 (*.UDL) 的创建

'引用 Microsoft OLE DB Service Component 1.0 Type Library
Option Explicit
Private Sub Command1_Click()
 Dim x As New MSDASC.DataLinks
 x.hWnd = Me.hWnd
 Dim s As String
 On Error GoTo ErrorHandler
 s = x.PromptNew
 On Error GoTo 0
 If VBA.Len(VBA.Trim(s & "")) > 0 Then
  Dim CommonDialog1 As New MSComDlg.CommonDialog
  CommonDialog1.DefaultExt = ".udl"
  CommonDialog1.Filter = "通用数据链接文件 (*.UDL)|*.udl"
  CommonDialog1.DialogTitle = "保存为通用数据链接文件"
  CommonDialog1.Flags = cdlOFNOverwritePrompt
  CommonDialog1.CancelError = True
  On Error GoTo ErrorHandler
  CommonDialog1.ShowSave
  On Error GoTo 0
  s = "[oledb]" & vbCrLf _
   & "; Everything after this line is an OLE DB initstring" & vbCrLf _
   & s & vbCrLf
  Dim BytesBuffer() As Byte
  BytesBuffer = VBA.StrConv(VBA.StrConv(s, vbUnicode), vbFromUnicode)
  Dim i As Long
  ReDim BytesBuffer0(1) As Byte
  BytesBuffer0(0) = 255 '&HFF
  BytesBuffer0(1) = 254 '&HFE
  If VBA.Len(VBA.Trim(VBA.Dir(CommonDialog1.FileName))) > 0 Then
   VBA.Kill CommonDialog1.FileName
  End If
  On Error GoTo ErrorHandler
  i = VBA.FreeFile
  Open CommonDialog1.FileName For Binary Access Write As #i
  Put #i, , BytesBuffer0
  Put #i, , BytesBuffer
  Close #i
  On Error GoTo 0
  If VBA.MsgBox("Test?", vbYesNo) = vbYes Then
   Dim adoConnection As New ADODB.Connection
   adoConnection.Open "File Name=" & CommonDialog1.FileName
   VBA.MsgBox "OK!"
  End If
 End If
 Exit Sub
ErrorHandler:
 If Err.Number <> 91 And Err.Number <> 32755 Then
  VBA.MsgBox Err.Number & ":" & vbCrLf & Err.Description
 End If
End Sub

Private Sub Command2_Click()
 Dim CommonDialog1 As New MSComDlg.CommonDialog
 CommonDialog1.DefaultExt = ".udl"
 CommonDialog1.Filter = "通用数据链接文件 (*.UDL)|*.udl"
 CommonDialog1.DialogTitle = "打开通用数据链接文件"
 'CommonDialog1.Flags = cdlOFNOverwritePrompt
 CommonDialog1.CancelError = True
 On Error GoTo ErrorHandler
 CommonDialog1.ShowOpen
 On Error GoTo 0
 If VBA.Len(VBA.Trim(VBA.Dir(CommonDialog1.FileName))) > 0 Then
  VBA.MsgBox GetConnectionStringFromUDL(CommonDialog1.FileName)
 End If
 Exit Sub
ErrorHandler:
 If Err.Number <> 91 And Err.Number <> 32755 Then
  VBA.MsgBox Err.Number & ":" & vbCrLf & Err.Description
 End If
End Sub

Public Function GetConnectionStringFromUDL(UDLFileName As String) As String
 If VBA.Len(VBA.Trim(VBA.Dir(UDLFileName & ""))) > 0 Then
  Dim BytesBuffer() As Byte
  ReDim BytesBuffer(VBA.FileLen(UDLFileName) - 133) As Byte
  Dim i As Long
  i = VBA.FreeFile
  Open UDLFileName For Binary Access Read As #i
  Get #i, 129, BytesBuffer
  Close #i
  GetConnectionStringFromUDL = VBA.Trim(VBA.StrConv(VBA.StrConv(BytesBuffer, vbFromUnicode), vbUnicode))
 End If
End Function

  • 0
    点赞
  • 0
    收藏
  • 打赏
    打赏
  • 0
    评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
©️2022 CSDN 皮肤主题:大白 设计师:CSDN官方博客 返回首页
评论

打赏作者

playyuer

你的鼓励将是我创作的最大动力

¥2 ¥4 ¥6 ¥10 ¥20
输入1-500的整数
余额支付 (余额:-- )
扫码支付
扫码支付:¥2
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值