Linkovanje sa poznatom putanjom

Code:

' Moraju se potvrditi reference za ADO i ADOX biblioteku
Function VerifyLinks(strDataDatabase As String, _
 strSampleTable As String, Optional strOpciono As String) As Boolean
    ' Proverava stanje veze sa pridruženim tabelama.
    ' Ako otkrije prekinutu vezu prvo pretražuje tekući direktorijum.
    ' Ako u njemu ne nađe traženu bazu podataka, korisniku prikazuje
    ' okvir za dijalog za otvaranje datoteka.
    ' Polazna pretpostavka: sve veze vode ka istoj ciljnoj .MDB datoteci.
    ' Ulaz:
    '     strDataDatabase - Ime bek end baze podataka
    '     strSampleTable  - Ime linkovane tabele za proveru
    '
    '     strOpciono  -     Opcioni parametar u formatu: ImeTabele/PoljeTabele:
    '                       ImeTabele - tabela u kojoj se čuva putanja direktorijuma baze
    '                       za podatke i druge direktorijume koje koristi program;
    '                       PoljeTabele - Ime polja u kome se čuva putanja
    '                       razdvojeni su znakom "/"
    ' Izlaz:
    '     Povratna vrednost - True Ako je uspešno; False u ostalim slučajevima
    '
    '        Ako je - True  opciono je ubačeno da ako postoji parametar strOpciono
    '                       ADO konekcijom upisuje novu putanju u polje poljeTabele
    
    On Error GoTo VerifyLinksErr
    Dim varReturn As Variant
    Dim strDBDir As String      ' direktorijum gde se nalazi baza sa podacima
    Dim strMsg As String
    Dim varFileName As Variant  ' putanja baza za podatke
    Dim intI As Integer
    Dim intNumTables As Integer
    Dim strProcName As String
    Dim strFilter As String
    Dim lngFlags As Long
    Dim Cnn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim fd As FileDialog
    Dim varSelektovanaStavka As Variant
    Dim rsPutanja As ADODB.Recordset
    Dim strSQL As String
    Dim intPozicija As Integer      ' pozicija karaktera razdvajanja "/" opcionog parametra strOpciono
    Dim strImeTabele As String      ' ime tabele u kojoj se čuva putanja za podatke
    Dim strPoljeTabele As String    ' ime polja tabele strImeTabele u kojoj je putanja podataka
    strProcName = "VerifyLinks"
    ' Ispitujemo stanje veze sa tabelom čije je ime zadato u parametru strSampleTable.
    varReturn = CheckLink(strSampleTable)
    If varReturn Then
        VerifyLinks = True
        GoTo VerifyLinksDone
    End If
    ' Učitavamo ime direktorijuma u kome se nalazi aplikaciona baza podataka.
    strDBDir = CurrentProject.Path & "\"
    ' Ime baze podataka „za podatke“ zadato je u parametru strDatadatabase.
    If (Dir$(strDBDir & strDataDatabase) <> "") Then
        ' Baza podataka je pronađena u tekućem direktorijumu.
        ' Dodati relinkovanje po potrebi!!!!!!!
        varFileName = strDBDir & strDataDatabase
    Else
        ' Potraži od korisnika da pronađe bazu za podatke koristeći FileDialog.
        strMsg = "Potreban fajl '" & strDataDatabase & "' nije mogao biti pronađen." & vbCrLf & _
         "Možete koristiti sledeći  dijalog boks da locirate fajl na Vašem sistemu." & vbCrLf & vbCrLf & _
         "Ako niste u mogućnosti da pronađete fajl ili niste sigurni šta trebate uraditi izaberite CANCEL" & vbCrLf & _
         "na sledećem ekranu i pozovite administratora programa."
        MsgBox strMsg, vbOKOnly + vbCritical, strProcName
        ' Prikaži FileDialog
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
            With fd
                .InitialView = msoFileDialogViewList
                .Title = "Lociranje fajla baze podataka"
                .ButtonName = "Izaberi"
                .AllowMultiSelect = False
                .InitialFileName = strDataDatabase
                    If .Show = -1 Then
                        For Each varSelektovanaStavka In .SelectedItems
                             varFileName = varSelektovanaStavka
                        Next varSelektovanaStavka
                    Else ' Korisnik je pritisnuo CANCEL
                        strMsg = "Nemožete koristiti ovu bazu " & _
                          "dok je ne locirate! '" & strDataDatabase & "'."
                        MsgBox strMsg, vbOKOnly, vbCritical, strProcName
                        VerifyLinks = False
                        GoTo VerifyLinksDone
                    End If
            End With
            Set fd = Nothing
        If Len(varFileName & "") = 0 Then
            ' Korisnik je pritisnuo Cancel.
            strMsg = "Nemožete koristiti ovu bazu " & _
             "dok je ne locirate! '" & strDataDatabase & "'."
            MsgBox strMsg, vbOKOnly, vbCritical, strProcName
            VerifyLinks = False
            GoTo VerifyLinksDone
        Else
             varFileName = Trim(varFileName)
        End If
    End If
    'Ponovno uspostavljanje veza. Najpre utvrđujemo ukupan broj tabela.
    Set Cnn = CurrentProject.Connection
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = Cnn
    intNumTables = cat.Tables.Count
    varReturn = SysCmd(acSysCmdInitMeter, _
     "Uspostavljam veze sa tavelama", intNumTables)
    ' Petlja za proveravanje svih tabela. Ponovo se povezuju samo one
    ' čije svojstvo Connect nesadrži prazan znakovni niz.
    intI = 0
    For Each tbl In cat.Tables
        If tbl.Type = "LINK" Then   'Ako je svojsto Type = "LINK", radi se o pridruženoj tabela.
            intI = intI + 1
            On Error Resume Next
                ' U sledećem redu veza se ponovo uspostavlja i osvežava.
                ' Ukoliko nova putanja nije u redu, nastaje greška kouju
                ' obrađujemo u sledećem redu.
                tbl.Properties("Jet OLEDB:Link Datasource") = varFileName
                'Ako je jedan link loš, return False.
            If err.Number <> 0 Then
                VerifyLinks = False
                GoTo VerifyLinksDone
            End If
        End If
        varReturn = SysCmd(acSysCmdUpdateMeter, intI + 1)
    Next tbl
        ' Ovde ubacuujemo novu putanju baze za podatke ako postoji opcioni parametar strOpciono
    If Not IsMissing(strOpciono) Then
        intPozicija = InStr(strOpciono, "/")
        strImeTabele = left(strOpciono, intPozicija - 1)
        strPoljeTabele = right(strOpciono, (Len(strOpciono) - intPozicija))
        strSQL = "SELECT " & strPoljeTabele & " FROM " & strImeTabele
        Set rsPutanja = New ADODB.Recordset
        rsPutanja.Open strSQL, Cnn, adOpenDynamic, adLockOptimistic
        If Not rsPutanja.EOF Then
            rsPutanja.Fields(strPoljeTabele) = varFileName
            rsPutanja.Update
        End If
        rsPutanja.Close
        Set rsPutanja = Nothing
    End If
    VerifyLinks = True
VerifyLinksDone:
    On Error Resume Next
        varReturn = SysCmd(acSysCmdRemoveMeter)
        Set tbl = Nothing
        Set cat = Nothing
        Set Cnn = Nothing
        Set fd = Nothing
        Set rsPutanja = Nothing
    Exit Function
VerifyLinksErr:
    Select Case err.Number
        Case Else
        err.Raise err.Number, err.Source, err.Description, err.HelpFile, err.HelpContext
        End Select
    Resume VerifyLinksDone
End Function


Private Function CheckLink(strTable As String) As Boolean
    ' Proverava stanje veze sa zadatom tabelom.
    ' (Zapravo, CheckLink daje False i kada tabela nepostoji.)
    ' Ulaz:
    '    strTable - Tabela za proveru
    ' Izlaz:
    '    Izlazna vrednost - True ako je uspešna; False u ostalim slučajevima
    On Error Resume Next
        Dim Cnn As ADODB.Connection
        Dim rst As ADODB.Recordset
        Set Cnn = CurrentProject.Connection
    ' Koristi metodu OpenSchema da popuni objekat tipa recordset sa podacima
    ' o kolonama tabele zadate u parametru strTable. Ako je skup podataka
    ' prazan to znači da Jet nije mogao da pronađe tabelu
    ' jer je veza verovatno prekinuta.
        Set rst = Cnn.OpenSchema(adSchemaColumns, _
             Array(Empty, Empty, strTable, Empty))
        CheckLink = Not rst.EOF
            rst.Close
        Set rst = Nothing
        Set Cnn = Nothing
End Function