Refresh eingebundene Tabellen

Praedator

Code

Public Sub ExterneTab_einbinden(Optional sDateityp As String = ".accdb", _
                                Optional boolEinbindenErzwingen As Boolean = False)
'***
'*** Zweck: Externe Tabellen werden neu eingebunden, dabei wird der Pfad der Access Datenbank verwendet
'*** Param: sDateityp              = Dateityp
'***        boolEinbindenErzwingen = True dann wird auch eingebunden, wenn die Quelle existiert
'*** Beisp: ExterneTab_einbinden
'*** Rueck: -
'***

  Dim dbs As DAO.Database, tdf As DAO.TableDef
  Set dbs = CurrentDb
  
  Dim sConnect As String
  Dim sLinkAlt As String, sLinkNeu As String
  Dim lFirstPos As Long, lLastPos As Long

  Dim lngAnz As Long, i As Long
  lngAnz = dbs.OpenRecordset("SELECT COUNT(*) FROM MSysObjects WHERE Database IS NOT NULL", dbOpenSnapshot)(0)

  For Each tdf In dbs.TableDefs
    sConnect = tdf.Connect

    If sConnect <> vbNullString Then

      If InStr(LCase(tdf.Connect), LCase(sDateityp)) > 0 Then

        'Anfangs- und Endposition des Pfades ermitteln
        'dabei pruefen, ob DATABASE der letzte Parameter ist
        lFirstPos = InStr(sConnect, "DATABASE=")
        If InStrRev(sConnect, ";") < lFirstPos Then
          lLastPos = Len(sConnect)
        Else
          lLastPos = InStr(lFirstPos, sConnect, ";") - 1
        End If
        
        sLinkAlt = Mid(sConnect, lFirstPos + 9, lLastPos - lFirstPos - 9 + 1)
        sLinkNeu = Left(Application.CurrentDb.Name, InStrRev(Application.CurrentDb.Name, "\")) & _
                   Right(sLinkAlt, Len(sLinkAlt) - InStrRev(sLinkAlt, "\"))
        
        If Dir(sLinkNeu) = "" And InStr(LCase(tdf.Connect), "_csv") = 0 Then
          If MsgBox("Fehler beim Einbinden der Tabellen!" & vbCrLf & _
                    "Tabelle '" & tdf.Name & "' konnte nicht eingebunden werden." & vbCrLf & vbCrLf & _
                    "Nächste Tabelle einbinden (Nein=Abbruch)", vbYesNoCancel) <> vbYes Then Exit For
        Else
          If LCase(sLinkAlt) <> LCase(sLinkNeu) Or boolEinbindenErzwingen Then
            'Neu einbinden
            sConnect = Left(sConnect, lFirstPos - 1) & "DATABASE=" & sLinkNeu & _
                       Right(sConnect, Len(sConnect) - lLastPos)
            tdf.Connect = sConnect
            tdf.RefreshLink
          End If
        End If
      End If
    End If
  Next tdf

  dbs.Close
  Set dbs = Nothing
 
End Sub

Alles anzeigen

Praedator

Dialog zur Farbauswahl

Eine Alternative wer die comdlg.dll nicht installiert hat.

Code

Declare Sub wlib_AccChooseColor Lib "msaccess.exe" Alias "#53" (ByVal Hwnd As Long, rgb As Long)

Sub Farbdialog()
  Dim lRgb As Long
 
  lRgb = 0
  wlib_AccChooseColor Application.hWndAccessApp, lRgb
  Debug.Print lRgb
End Sub

Praedator

Dialog Ordner öffnen

Code

  Dim objShell As Object, objFolder As Object
  Set objShell = CreateObject("Shell.Application")

  Set objFolder = objShell.BrowseForFolder(0, "Ordner wählen", 0)
  If Not objFolder Is Nothing Then
    If objFolder.Self.Path <> "" Then
      MsgBox objFolder.Self.Path
    End If
  End If

Praedator

Dialog Datei öffnen

Code

With Application.FileDialog(1)
  .Title = Title
  .AllowMultiSelect = False
  .Filters.Clear
  .InitialFileName = Standardpfad & "\"
  Select Case VarianteFilter
    Case 1:    .Filters.Add "Alle Dateien (*.*)", "*.*"
    Case Else: .Filters.Add "Micrsoft Excel-Dateien (*.xls)", "*.xls"
               .Filters.Add "Alle Dateien (*.*)", "*.*"
  End Select

  If .Show = -1 Then
    strDatei = .SelectedItems(1)
  Else
    strDatei = ""
  End If
End With

MsgBox strDatei

Alles anzeigen

Refresh eingebundene Tabellen

Dialog zur Farbauswahl

Dialog Ordner öffnen

Dialog Datei öffnen

Tags

Benutzer online in diesem Thema