title image


Smiley Endlich! VBA: Alle Module aller Templates exportieren
Hallo!



Ich wollte dieses Kleinod doch der breiten Öffentlichkeit nicht vorenthalten.

Dient zum Sichern aller Module.

BasePath strConstBasePath bitte anpassen.



Gruß, Christoph











Option Explicit



' Word 2000



Sub CallOnModuleExportieren()

    

    ' Exportiert alle Module aller Dokumentenvorlagen aller offenen Dokumente

    ' plus normal.dot in einen neuen Ordner mit Datumsstempel und ggf. laufender

    ' Nummer (AutoExport_2003_10_22_6).

    ' Funktioniert auch bei keinem offenen Dokument (normal.dot sichern).

    ' Stellt jedem Dateinamen eines Moduls den Namen seiner Dokumentenvorlagen voran

    ' (z.B. NormalDot_ModulTools).

    

    ' Die Verwendung von # in der Mini LookUp-Tabelle sichert, dass

    ' bei der Prüfung genau das ganze Wort (Name des Templates)

    ' geprüft wird (Ohne # würde z.B. für "info"

    ' TextinfossammelnSymbolleistenzeigen [statt #Textinfossammeln#Symbolleistenzeigen#]

    ' fälschlich als enthält erkannt

    ' (obwohl info zu kurz ist); oder "dottest" würde bei testdottestfuerRange

    ' [statt #testdot#testfuerRange#]

    ' fälschlich als enthält erkannt (Ende bzw. Anfang zweier Namen

    ' werden fälschlich als zusammengehörig gesehen)).

    ' Daher das # bei instr etc.

    

    ' Pfad bitte anpassen (bitte mit \ am Ende):

    Const strConstBasePath = _

             "C:\Dokumente und Einstellungen\All Users\Dokumente\Meins3\"

    ' Titel:

    Const strConstTitel = _

             "Sichern aller Module aller geöffneten Dokumente"



    Dim docMyDoc1             As Document

    Dim strMeinPfad           As String

    Dim templateMyNormalDot   As Template

    Dim strAlleTemplates      As String     ' Mini LookUp-Tabelle

    Dim intI                  As Integer

    Dim strBasePath           As String

    

    

    ' Ggf. Abbruch

    If Dir(strConstBasePath & "", vbDirectory) = "" Then

        MsgBox "Abbruch: Base Path existiert nicht.", _

               vbCritical, _

               strConstTitel

        End

    End If

    

    strBasePath = strConstBasePath & "AutoExport"

    strMeinPfad = ""

    ErstellePfad strBasePath, strMeinPfad

    

    ' Ggf. Abbruch

    If strMeinPfad = "" Or _

       Dir(strMeinPfad & "", vbDirectory) = "" Then

        MsgBox "Das Verzeichnis mit dem Namen " & _

               vbNewLine & _

               strMeinPfad & _

               " existiert nicht. Deshalb Abbruch.", _

               vbCritical, _

               "Fehler in: " & strConstTitel

        End 'Abbruch

    End If

    

    Set templateMyNormalDot = Application.Templates.Item("Normal.dot")

    ModuleExportieren templateMyNormalDot, _

                      "Normal_Dot", _

                      strMeinPfad

    strAlleTemplates = strAlleTemplates & _

                       "#" & templateMyNormalDot & "#"

    

    ' Schleife

    For Each docMyDoc1 In Application.Documents

        

        If InStr(1, strAlleTemplates, "#" & docMyDoc1.AttachedTemplate.Name & "#") = 0 Then

            ModuleExportieren docMyDoc1.AttachedTemplate, _

                              Replace(docMyDoc1.AttachedTemplate.Name, ".", "_"), _

                              strMeinPfad

            ' Zum # s.o.

            strAlleTemplates = strAlleTemplates & "#" & _

                               docMyDoc1.AttachedTemplate.Name & _

                               "#"

            intI = intI + 1

        End If

    

    Next docMyDoc1



    ' Meldung (intI + 1 wegen Normal.dot außerhalb der Schleife)

    MsgBox "Fertig." & _

           vbNewLine & _

           "Pfad war:  " & _

           vbNewLine & _

           strMeinPfad & _

           "." & _

           vbNewLine & _

           "Templates waren: " & _

           Replace(strAlleTemplates, "#", "  ") & "." & _

           vbNewLine & "Gesichert: " & _

           intI + 1 & ".", _

           vbInformation, _

           strConstTitel

        

End Sub



Private Sub ErstellePfad(strLocalBasePath As String, _

                         strMeinPfad As String)



    ' Ordner erstellen

    

    Dim intI                As Integer

    Dim strOldMeinPfad      As String

    Dim strMeinPfadBuffer   As String

    

    

    strMeinPfadBuffer = strLocalBasePath



    ' Datumsstempel

    strMeinPfadBuffer = strMeinPfadBuffer & "_" & _

                        Format(Date, "yyyy_mm_dd")

    

    strOldMeinPfad = strMeinPfadBuffer

    ' Schleife: ggf. mehrere Sicherungen am Tag: durchnummerieren

    While Dir(strMeinPfadBuffer & "", vbDirectory) <> "" And intI < 30000

        intI = intI + 1

        strMeinPfadBuffer = strOldMeinPfad & "_" & Trim(Str(intI))

    Wend

    

    On Error Resume Next

    ' Verzeichnis erstellen

    MkDir strMeinPfadBuffer

    ' Fehlerhandling:

    If Err <> 0 Then

        MsgBox "Ergab Fehlernr. " & Err & "." & _

               vbNewLine & _

               "Beschreibung: " & Err.Description & ".", _

               vbCritical, _

               "Abbruch"

        End

    End If

    On Error GoTo 0

    strMeinPfadBuffer = strMeinPfadBuffer + "\"

    ' Rückgabewert

    strMeinPfad = strMeinPfadBuffer



End Sub



Private Sub ModuleExportieren(templateMyTemplate As Template, _

                              strDateiZusatz As String, _

                              strMeinPfad As String)



    ' Export



    Dim vbcMeinVBComponent  As vbcomponent

    

    

    ' Schleife

    For Each vbcMeinVBComponent In templateMyTemplate.VBProject.VBComponents



        vbcMeinVBComponent.Export strMeinPfad & _

                                  strDateiZusatz & _

                                  "_" & _

                                  vbcMeinVBComponent.CodeModule

    

    Next vbcMeinVBComponent

    

End Sub







Code eingefügt mit Syntaxhighlighter 2.5





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: