Excel vba Addin-Code zum Tauschen von Excel Pfaden in Verknüpfungen
Das folgende vba Makro tauscht alle Verknüpfungen in einer Excel Datei zu einem neuen Pfad.
Dabei ist das makro zusätzlich als Excel Addin geschrieben, wodurch man die Datei einfach öffnen muss und die Datei dann als Menü->Addin->addin zur Verfügung steht in jeder Excel Datei
Vba Makro Code
Folgend der reine vba Makro Code zum Tauschen der Excel Links.
Dabei werden in diesem Fall direkt die Excel LinkSources geändert.
In Excel sind Workbook.LinkSources direkt die internen Verknüpfungen, welche von Zellen oder Names-Bezügen und auch von Graphiken und eingebetteten OLE Objekten aus gehen.
Vba Code in Excel
Vba Macro Code
Option Explicit Public Sub fx_Pfade_austauschen() '----------------< fx_Pfade_austauschen() >----------------
'< get_Paths > '='C:\Users\poppr\Desktop\Excel\Excel\20190214_Pfade_aendern\[Excel_mit_Wert_A_inC3.xlsx]Sheet1'!B$2 Dim sPfad_Alt As String sPfad_Alt = "C:\Users\poppr\Desktop\Excel\Excel\20190214_Pfade_aendern\Excel_mit_Wert_A_inC3.xlsx" sPfad_Alt = LCase(sPfad_Alt)
Dim sPfad_Neu As String sPfad_Neu = "C:\Users\poppr\Desktop\Excel\Excel\20190214_Pfade_aendern\Excel_mit_Wert_B_inC3.xlsx" sPfad_Neu = LCase(sPfad_Neu) '</ get_Paths >
'< get_Document > Application.StatusBar = Now & " start Pfade austauschen von " & sPfad_Alt & " -> " & sPfad_Neu Dim wb As Workbook Set wb = ActiveWorkbook '</ get_Document >
On Error Resume Next '*if no ole objects or excelLinks exits
'----< @Loop: External_Links >---- Dim sLink As Variant For Each sLink In wb.LinkSources(1) '----< IsLinkSource >---- sLink = LCase(sLink) If sLink Like "*" & sPfad_Alt & "*" Then '---< Contains_Path >--- '< replace > Dim sLink_neu As String sLink_neu = Replace(sLink, sPfad_Alt, sPfad_Neu, , , vbTextCompare) '</ replace >
'< change_linksource > wb.ChangeLink sLink, sLink_neu, xlLinkTypeExcelLinks wb.ChangeLink sLink, sLink_neu, xlLinkTypeOLELinks '</ change_linksource > '---</ Contains_Path >--- End If '----</ IsLinkSource >---- Next '----</ @Loop: External_Links >----
'< Abschluss > On Error GoTo 0 Application.StatusBar = Now & " Fertig." MsgBox "Fertig" '</ Abschluss > '----------------</ fx_Pfade_austauschen() >---------------- End Sub |
Addin-Code
Folgend der addin-code (klassisches Addin in der xlam datei
Der klassische Addin-Code ist deshalb Sinnvoll, weil man keine Exe ausführen kann.
Addin in klassischem vba Addin
Option Explicit Option Compare Text
'************************************************************** '=====================================< Variablen >===================================== Const °AddinName As String = "Addin_Pfade_anpassen_20190214_1449" '=====================================</ Variablen >=====================================
'=====================================< Workbook >===================================== Private Sub Workbook_AddinInstall() '---------------------------------< Workbook_AddinInstall() >--------------------------------- Dim mBar As CommandBar Set mBar = Application.CommandBars(1) On Error Resume Next
Dim mMenu As CommandBarControl Dim v v = Application.CommandBars.FindControl(msoControlPopup, Application.CommandBars(1).Controls(°AddinName).ID)
If Err.Number > 0 Then Set mMenu = mBar.Controls.Add(msoControlPopup, , , 9, False) mMenu.Caption = °AddinName mMenu.TooltipText = °AddinName Else Set mMenu = Application.CommandBars.FindControl(msoControlPopup, Application.CommandBars(1).Controls(°AddinName).ID) End If
Dim vModul As String vModul = "" 'sAddinName & ".DieseArbeitsmappe."
'--------------------< Menuepunkte eintragen >--------------------
'------------< Untermenue : Hauptebene >------------ Dim ctrl1 As CommandBarButton Dim mSubMenu As CommandBarControl
'------------< 1 >------------ Set ctrl1 = mMenu.Controls.Add ctrl1.Caption = "Pfade austauschen" 'ctrl1.Tag = "fxProtect" 'ctrl1.TooltipText = "INI aus, schuetzen, Pos1" ctrl1.OnAction = vModul & "fx_Pfade_austauschen" ctrl1.FaceId = 893 ctrl1.Style = msoButtonIconAndCaption ctrl1.BeginGroup = True '------------</ 1 >------------
'---------------------------------</ Workbook_AddinInstall() >--------------------------------- End Sub
Sub Workbook_AddinUninstall() '---------------------------------< Workbook_AddinUninstall() >--------------------------------- Dim mMenu On Error Resume Next Set mMenu = Application.CommandBars.FindControl(msoControlPopup, Application.CommandBars(1).Controls(°AddinName).ID) mMenu.Delete '---------------------------------</ Workbook_AddinUninstall() >--------------------------------- End Sub
'=====================================</ Workbook >===================================== |