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

2008-04-10 03:07:22来源:互联网 阅读 ()

新老客户大回馈,云服务器低至5折

引用 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

标签:

版权申明:本站文章部分自网络,如有侵权,请联系:west999com@outlook.com
特别注意:本站所有转载文章言论不代表本站观点,本站所提供的摄影照片,插画,设计作品,如需使用,请与原作者联系,版权归原作者所有

上一篇:在VB中终止Win9X

下一篇:未公开API函数揭秘——通用对话框