Access VBA

css navigation by Css3Menu.com

Relink ODBC Tables

My internal customer wants frequent updates of data that is hard to get to.

First it is on a remote system that he cannot access. Second, it is in a half dozen databases that are have tables that are the same names but put together differently.

Sub MakeNewTables()
    Dim sqlSTR      As String
    Dim Loc         As String
    Dim LocArray    As Variant
    Dim zLoc        As Long

    On Error GoTo ErrHands
 '   Loc = InputBox("What is the location identifier you are working in?", "Location", "BHM")
	'All location identifiers in Array   
    LocArray = Array("ARB", "TEX", "ARK", "BHM", "CAS")
    For zLoc = LBound(LocArray) To UBound(LocArray) 'If I add locations I'm ready   
        Loc = LocArray(zLoc)	'Get the text value   
        FixLink (Loc)		'Relink the current location   

    DoCmd.SetWarnings False
    sqlSTR = "SELECT V_OD_HEADER.* INTO V_OD_Header_" & Loc & " FROM V_OD_HEADER;"
    DoCmd.RunSQL sqlSTR
    	'Need to make the SQL more generic   
    sqlSTR = "SELECT V_OD_HEADER_DEL.* INTO V_OD_Header_DEL_" & Loc & " FROM V_OD_HEADER_DEL;"
    DoCmd.RunSQL sqlSTR
    
    sqlSTR = "SELECT V_OD_LINES.* INTO V_OD_Lines_" & Loc & " FROM V_OD_LINES;"
    DoCmd.RunSQL sqlSTR
    
    sqlSTR = "SELECT V_OD_LINES_DEL.* INTO V_OD_Lines_DEL_" & Loc & " FROM V_OD_LINES_DEL;"
    DoCmd.RunSQL sqlSTR
        
    Next zLoc
    DoCmd.SetWarnings True	'Give back control   
    MsgBox "Created tables for " & now(), vbInformation 'Tell them its done   
    Exit Sub
ErrHands:
    MsgBox "Please report " & Err.Number & vbCrLf & Err.Description, vbCritical
End Sub


Sub FixLink(Loc As String)
    Dim Z       As Long
    Dim cTl     As Control
    Dim Tdef    As DAO.TableDef
   ' Dim Loc     As String
    
    On Error GoTo ErrHam
    Z = 0
    For Each Tdef In CurrentDb.TableDefs
    '' check if table is a linked table 
If Len(Tdef.Connect) > 0 Then Tdef.Connect = "ODBC;DSN=Globbal_" & Loc _ & ";APP=Microsoft Access 2010;DATABASE=GLObBAL;Uid=Grobal;DBQ=GLObBAL" & Loc Tdef.RefreshLink Z = Z + 1 End If Next Exit Sub ErrHam: MsgBox "Report screwup " & Err.Number & vbCrLf & Err.Description, vbExclamation End Sub

My next mission is to build a task that will kick off at 02:00 every morning and run this whole mess. Then delete the parts that we cannot show to the customer.

© 2015-2017

Updated:  06/14/2017 17:53
This page added:  20 May 2015