Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User

Word vba: Erstellen eines vba Word Addins

22.02.2019 (👁941)


 

Man kann unter Word ein klassisches Word Addin erstellen, indem man in Word-vba  einen Addin-Code schreibt und dann die Word Datei als Word Vorlage mit Makros (*.dotm) speichert

 

 

*die Word Dateien sind im Download als Vorlage vorhanden. Hier könnt ihr den Code entnehmen

 

 

Erstellen eines Word-Addin

Indem man eine Datei mit vba Macro Code speichert und Word Vorlage mit Makros *.dotm

 

 

Einfügen des Addins

Im Gegensatz zu Excel und PowerPoint werden Word Addins als Word-Vorlage mit Makro .dotm gespeichert und geladen

 

Word Addin-code

Unter Project->Microsoft Word Objekte->ThisDocument

Damit Word als Addin Installiert wird, muss es im Document auf das Document_open() und Document_close() reagieren.

Einfach den folgenden code dort installieren

Public Sub AutoExec()  ' Document_Open, Document_New, AutoOpen, AutoNew, etc.

    create_Addin_Menu

End Sub

 

Public Sub AutoClose()  ' Document_Open, Document_New, AutoOpen, AutoNew, etc.

    create_Addin_Menu

End Sub

 

 

Private Sub Document_Close()

    Delete_Addin_Menu

End Sub

 

 

Private Sub Document_Open()

    create_Addin_Menu

End Sub

 

 

 

 

 

Word Addin-code

Unter Project->Module->mdl_Addin

Folgend der Installationscode für die CommandBars in Word-Addins

Option Explicit

Option Compare Text

 

'*Installation Addin->Menubar

 

Const °AddinName As String = "Pfade_anpassen"

 

 

Sub Auto_Open()

    '----------------< Auto_Open() >----------------

   

    '--< Install_MenuBar >--

    Dim addin_Commandbar As CommandBar

    Set addin_Commandbar = find_Commandbar(°AddinName)

    '< check >

    If Not addin_Commandbar Is Nothing Then

        addin_Commandbar.Visible = True

        Exit Sub

    End If

    '</ check >

   

    On Error GoTo 0

    '--< Install_MenuBar >--

   

    '< create new >

    Set addin_Commandbar = CommandBars.Add(Name:=°AddinName, Position:=msoBarFloating, Temporary:=False)

    '</ create new >

   

    '----< Menue_Punkte_einfuegen >----

    Dim control_Element As CommandBarButton

 

    '------------< 1 >------------

    Set control_Element = addin_Commandbar.Controls.Add

    control_Element.Caption = "Pfade austauschen"

    control_Element.OnAction = "fx_Pfade_austauschen"

    control_Element.FaceId = 893

    control_Element.Style = msoButtonIconAndCaption

    control_Element.BeginGroup = True

    '------------</ 1 >------------

    '----</ Menue_Punkte_einfuegen >----

 

    '< anzeigen >

    addin_Commandbar.Visible = True

    '</ anzeigen >

    

    '----------------</ Auto_Open() >----------------

End Sub

 

 

 

 

Sub Auto_Close()

    '----------------< Uninstall in PowerPoint ??() >---------------

    '--< find_commandbar >--

    Dim addin_Commandbar As CommandBar

    Set addin_Commandbar = find_Commandbar(°AddinName)

    '< check >

    If Err.Number <> 0 Then Exit Sub

    If addin_Commandbar Is Nothing Then Exit Sub

    '</ check >

    '--</ find_commandbar >--

   

    addin_Commandbar.Delete

   

    '----------------</ Uninstall in PowerPoint ??() >---------------

End Sub

 

 

 

 

 

'=====================< Helper-Functions >==============

 

Public Function find_Commandbar(ByVal sName As String) As CommandBar

    '-----------< find_Commandbar() >--------------

    Dim search_Commandbar As CommandBar

    '----< @Loop: all_Commandbars >----

    For Each search_Commandbar In Application.CommandBars

        If search_Commandbar.Name = sName Then

            '< match_return >

            Set find_Commandbar = search_Commandbar

            Exit Function 'not necessary

            '</ match_return >

        End If

    Next

    '----</ @Loop: all_Commandbars >----

   

    '< nomatch >

    Set find_Commandbar = Nothing

    '</ nomatch >

    '-----------</ find_Commandbar() >--------------

End Function

 

'=====================</ Helper-Functions >==============

 

 

 

 

 

Beispiel Code

Pfade zu Verzeichnissen komplett Ändern in allen Word Dokumenten

Im Modul mdlPfad_aendern

 

Code zum Austauschen aller Links und gebundenen Grafiken und Objekte zu einem anderen Pfad

Option Explicit

 

'----< SETUP >----

Const °Pfad_Alt = "C:\Demo_Pfad_ALT"

Const °Pfad_Neu = "D:\NEUER_PFAD"

'----</ SETUP >----

 

 

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 = °Pfad_Alt

    sPfad_Alt = LCase(sPfad_Alt)

   

    Dim sPfad_Neu As String

    sPfad_Neu = °Pfad_Neu

    sPfad_Neu = LCase(sPfad_Neu)

    '</ get_Paths >

   

    '< init >

    Dim objWord As Word.Document

    Set objWord = ActiveDocument

    '</ init >

   

   

    '--------< @Loop: Hyperlinks >--------

    '*loop all Hyperlinks

    Dim sAddress As String

   

    Dim link As Hyperlink

    For Each link In objWord.Hyperlinks

        '------< Hyperlink >------

         sAddress = link.Address

         sAddress = LCase(sAddress)

         If sAddress Like "*" & sPfad_Alt & "*" Then

             '< Link aendern >

             Dim sAddress_neu As String

             sAddress_neu = Replace(sAddress, sPfad_Alt, sPfad_Neu, 1, , vbTextCompare)

            link.Address = sAddress_neu

             '< Link aendern >

         End If

        '------</ Hyperlink >------

    Next

    '------</ @Loop: Hyperlink >------

   

 

    Dim objShape As Shape

    '------< @Loop: Shapes >------

    For Each objShape In objWord.Shapes

        '------< Shape >------

        If objShape.Type = msoLinkedOLEObject Then

            '----< IsLinkedOLEObject >----

            Dim sLink As String

            sLink = objShape.LinkFormat.SourceFullName

            sLink = LCase(sLink)

            If sLink Like "*" & sPfad_Alt & "*" Then

                '< Link aendern >

                Dim sLink_neu As String

                sLink_neu = Replace(sLink, sPfad_Alt, sPfad_Neu, 1, , vbTextCompare)

                objShape.LinkFormat.SourceFullName = sLink_neu

                '< Link aendern >

            End If

           '----</ IsLinkedOLEObject >----

        End If

        '------</ Shape >------

    Next

    '------</ @Loop: Shapes >------

 

 

   

    '------</ Change_Cells >------

   

    '< Abschluss >

    MsgBox "Fertig"

    '</ Abschluss >

    '----------------</ fx_Pfade_austauschen() >----------------

End Sub