'Reference 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 commit =" .ud "commonDialog1.filter =" universal data link file (* .UDL) | * .udl "Commondialog1. DialogTitle = "universal data link file save as" 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 = "Universal Data Link files (* .UDL) | * .udl" CommonDialog1.DialogTitle = "open a Universal Data Link File" '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 SubPublic Function GetConnectionStringFromUDL (UDLFileName As String) As String if vba.len (VBA.TRIM (VBA.Dir (UdlFileName & "))))))> 0 THEN DIM BYTESBuffer () AS BYTE Redim Bytesbuffler (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.STRCON v (vba.strconv (bytesbuffer, vbfromunicore), vbunicode)) end ifend function
