'引用 Microsoft OLE DB Service Component 1.0 Type LibraryOption ExplicitPrivate 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 SubErrorHandler: If Err.Number <> 91 And Err.Number <> 32755 Then VBA.MsgBox Err.Number & ":" & vbCrLf & Err.Description End IfEnd 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 SubErrorHandler: If Err.Number <> 91 And Err.Number <> 32755 Then VBA.MsgBox Err.Number & ":" & vbCrLf & Err.Description End IfEnd 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 IfEnd Function
