Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Chris Miller on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

DAO to ADO Conversion Help

Status
Not open for further replies.
mtompkins

mtompkins

IS-IT--Management
Jan 14, 2003
166
US
I am trying to convert the following code from DAO to ADO. It is really useful for having front ends relocate backends. (And it was from this site - great little code). I'd like to convert it to ADO to keep all the coding in my project in that form.

I could use some help...

Basically in the two functions - CheckLinks and RefreshLinks - it tries to connect to the backend. If an error connecting occurs it prompts for location. I have added "remarks" on what I've tried - however it does not function as intended.

Kindest,
Mark Tompkins

Code: 
Option Compare Database

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
    "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean

Declare Function FindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal lpClassName As String, _
                    ByVal lpWindowName As Long) As Long

Declare Function SendMessage Lib "user32" Alias _
    "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
                    ByVal wParam As Long, _
                    ByVal lParam As Long) As Long

Type MSA_OPENFILENAME
    strFilter As String
    lngFilterIndex As Long
    strInitialDir As String
    strInitialFile As String
    strDialogTitle As String
    strDefaultExtension As String
    lngFlags As Long
    strFullPathReturned As String
    strFileNameReturned As String
    intFileOffset As Integer
    intFileExtension As Integer
End Type

Const ALLFILES = "All Files"

Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As Long
    nMaxCustrFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustrData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type

Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10

Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
    Dim strFilter As String
    Dim intRet As Integer
    Dim intNum As Integer
    intNum = UBound(varFilt)
    If (intNum <> -1) Then
        For intRet = 0 To intNum
            strFilter = strFilter & varFilt(intRet) & vbNullChar
        Next
        If intNum Mod 2 = 0 Then
            strFilter = strFilter & "*.*" & vbNullChar
        End If
        strFilter = strFilter & vbNullChar
    Else
        strFilter = ""
    End If
    MSA_CreateFilterString = strFilter
End Function

Function MSA_ConvertFilterString(strFilterIn As String) As String
    Dim strFilter As String
    Dim intNum As Integer, intPos As Integer, intLastPos As Integer
    strFilter = ""
    intNum = 0
    intPos = 1
    intLastPos = 1
    Do
        intPos = InStr(intLastPos, strFilterIn, "|")
        If (intPos > intLastPos) Then
            strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
            intNum = intNum + 1
            intLastPos = intPos + 1
        ElseIf (intPos = intLastPos) Then
            intLastPos = intPos + 1
        End If
    Loop Until (intPos = 0)
    intPos = Len(strFilterIn)
    If (intPos >= intLastPos) Then
        strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
        intNum = intNum + 1
    End If
    If intNum Mod 2 = 1 Then
        strFilter = strFilter & "*.*" & vbNullChar
    End If
    If strFilter <> "" Then
        strFilter = strFilter & vbNullChar
    End If
    MSA_ConvertFilterString = strFilter
End Function

Private Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
    Dim of As OPENFILENAME
    Dim intRet As Integer
    MSAOF_to_OF msaof, of
    of.flags = of.flags Or OFN_HIDEREADONLY
    intRet = GetSaveFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetSaveFileName = intRet
End Function

Function MSA_SimpleGetSaveFileName() As String
    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
    intRet = MSA_GetSaveFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    MSA_SimpleGetSaveFileName = strRet
End Function

Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
    Dim of As OPENFILENAME
    Dim intRet As Integer
    MSAOF_to_OF msaof, of
    intRet = GetOpenFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetOpenFileName = intRet
End Function

Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
    msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
    Dim strFile As String * 512
    of.hwndOwner = Application.hWndAccessApp
    of.hInstance = 0
    of.lpstrCustomFilter = 0
    of.nMaxCustrFilter = 0
    of.lpfnHook = 0
    of.lpTemplateName = 0
    of.lCustrData = 0
    If msaof.strFilter = "" Then
        of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
    Else
        of.lpstrFilter = msaof.strFilter
    End If
    of.nFilterIndex = msaof.lngFilterIndex
    of.lpstrFile = msaof.strInitialFile _
        & String(512 - Len(msaof.strInitialFile), 0)
    of.nMaxFile = 511
    of.lpstrFileTitle = String(512, 0)
    of.nMaxFileTitle = 511
    of.lpstrTitle = msaof.strDialogTitle
    of.lpstrInitialDir = msaof.strInitialDir
    of.lpstrDefExt = msaof.strDefaultExtension
    of.flags = msaof.lngFlags
    of.lStructSize = Len(of)
End Sub

Public Function RelinkTables() As Boolean
On Error Resume Next
Const conNonExistentTable = 3011
Const conNotconEEC3Data = 3078
Const conEEC3DataNotFound = 3024
Const conAccessDenied = 3051
Const conReadOnlyDatabase = 3027
Const conNotValidPath = 3044
Const conDiskNetworkError = 3043
Const conAppTitle = "WITS Trade Management"   'edit this
Dim strSearchPath As String
Dim strFileName As String
Dim strError As String
Dim strDatabase As String
Dim frm_ActiveForm As Form
Dim msg As String
Set frm_ActiveForm = Screen.ActiveForm
    strDatabase = "TradeManagement_be.mdb"  'type in the name of the DB to link to
    strSearchPath = "C:\My Documents\"   'type in the default search directory
    Err.Clear
Err_strSearchPath:
    If (Dir(strSearchPath & strDatabase) <> "") Then
        strFileName = strSearchPath & strDatabase
    Else
        msg = "Couldn't find shared data for " & conAppTitle & " ."
        msg = msg & "You must locate " & strDatabase & "."
        msg = msg & " Are you connected to the Network?"
        MsgBox msg, vbInformation, "Refresh Links"
        strFileName = FindSharedData(strSearchPath)
        If strFileName = "" Then
            strError = "Sorry, you must locate " & strDatabase & " to open " & conAppTitle & "."
            GoTo Exit_Failed
        End If
    End If
    frm_ActiveForm.Repaint
     If RefreshLinks(strFileName) Then
        RelinkTables = True
        Exit Function
    End If
    If Err = conNotValidPath Or Err = conDiskNetworkError Or Err = conEEC3DataNotFound Then
        strSearchPath = "S:\"    ' type in what you want to be an alternative search direcory
        GoTo Err_strSearchPath
    End If
    Select Case Err
    Case conNonExistentTable, conNotconEEC3Data
        strError = "File '" & strFileName & "' does not contain the required " & strDatabase & " ."
    Case Err = conEEC3DataNotFound
        strError = "You can't run " & conAppTitle & " until you locate " & strDatabase & " ."
    Case Err = conAccessDenied
        strError = "Couldn't open " & strFileName & " because it is read-only or located on a read-only share."
    Case Err = conReadOnlyDatabase
        strError = "Can't reattach tables because " & conAppTitle & " is read-only or is located on a read-only share."
    Case Else
        strError = Err.Description
    End Select
Exit_Failed:
    MsgBox "Table Links Error", vbCritical, conAppTitle
    RelinkTables = False
End Function

Function FindSharedData(strSearchPath) As String
On Error Resume Next
Dim msaof As MSA_OPENFILENAME
    msaof.strDialogTitle = "Browse to Trade Management_be.mdb..."  'edit this to you Back End DB name
    msaof.strInitialDir = strSearchPath
    msaof.strFilter = MSA_CreateFilterString("Access Databases", "*.mdb;*.mde")
    MSA_GetOpenFileName msaof
    FindSharedData = Trim(msaof.strFullPathReturned)
End Function

Function MSA_SimpleGetOpenFileName() As String
On Error Resume Next
Dim msaof As MSA_OPENFILENAME
Dim intRet As Integer
Dim strRet As String
    intRet = MSA_GetOpenFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    MSA_SimpleGetOpenFileName = strRet
End Function

Public Function CheckLinks() As Boolean
On Error Resume Next
Dim dbs As Database, rst As Recordset
'Dim dbs As ADODB.Connection
'Dim rst As ADODB.Recordset

'Set dbs = New ADODB.Connection
'Set rst = New ADODB.Recordset

Set dbs = CurrentDb()

'Open the connection
'    dbs.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
'    "Persist Security Info=False;" & _
'    "User ID=Admin;" & _
'    "Data Source=" & CurrentProject.Path & _
'    "\TradeManagement.mdb;"
    
'rst.ActiveConnection = CurrentProject.Connection

'rst.Open "SELECT * FROM tblFirms;"
Set rst = dbs.OpenRecordset("tblFirms")  'type in a linked table name here
    If Err = 0 Then
        CheckLinks = True
    Else
        CheckLinks = False
    End If
'rst.Close
'Set rst = Nothing

End Function

Private Sub OF_to_MSAOF1(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
On Error Resume Next
    msaof.strFullPathReturned = Left$(of.lpstrFile, InStr(of.lpstrFile, Chr$(0)))
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

Private Function RefreshLinks(strFileName As String) As Boolean
On Error Resume Next
Dim dbs, dbsRefresh As Database
Dim intCount As Integer
Dim tdf As TableDef
    Set dbsRefresh = OpenDatabase(strFileName, False, False, "; pwd=") 'edit this if db is passworded (pwd=1234)
    Set dbs = CurrentDb()
    For intCount = 0 To dbs.TableDefs.Count - 1
        Set tdf = dbs.TableDefs(intCount)
        If Len(tdf.Connect) > 0 Then
            tdf.Connect = ";DATABASE=" & strFileName
            Err = 0
            On Error Resume Next
            tdf.RefreshLink
            If Err <> 0 Then
                RefreshLinks = False
                Exit Function
            End If
        End If
    Next intCount
    dbsRefresh.Close
    'DoCmd.OpenForm "frmTradingLedger" 'edit this to your "Switchboard" or startup form.
    DoCmd.Echo True, ""
    RefreshLinks = True
End Function

Function AutoExec()
On Error Resume Next
    If CheckLinks() = False Then
        If RelinkTables() = False Then
            DoCmd.Quit acExit
        End If
    End If
End Function
 
Sort by date Sort by votes
Status
Not open for further replies.

Similar threads

DarkOne72
  • Locked
  • Question
Message Box Popup on certain days help !
2
Replies
23
Views
2K
Norman Sherlock
Norman Sherlock
Zyborg
  • Question
Using a variable as reference to a form
Replies
5
Views
215
Zyborg
Zyborg
Kennelbloke
  • Locked
  • Solved
Refer to Navigation Control Subform Record
Replies
8
Views
549
Kennelbloke
Kennelbloke
renigar
  • Locked
  • Question
Code to write file path to field always writes to 1st record 1
Replies
5
Views
350
dhookom
dhookom
Viswa.R
  • Locked
  • Question
Dimension import from Autocad to Excel
Replies
0
Views
271
Viswa.R
Viswa.R

Part and Inventory Search

Sponsor

Back
Top