title image


Smiley Re: Endlich! VBA: Alle Module aller Templates exportieren
Neuer Code mit den Änderungen von U.Miller.

Immer noch alle Module in ein Verzeichnis (Sorry an Jock).









Option Explicit



' Word 2000

' Win XP / Win 2000



' Word braucht im VBA-Editor

' im Menü Extras | Verweise

' einen Verweis auf

' "Microsoft Visual Basic for Applications Extensibility 5.3"



' Gut ist auch

' http://mypage.bluewin.ch/reprobst/WordFAQ/VBAMd.htm





Public 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).

    

    ' Es gibt eine Mini LookUp-Tabelle (ein string), die dazu dient, dass

    ' jede Dokumentenvorlage nur einmal gesichert wird.

    '

    ' 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 (in diesem Pfad wird der neue Ordner mit

    ' Datumsstempel erstellt) (wahlweise mit oder \ am Ende):

    Const strConstBasePath = _

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

    ' Titel:

    Const strConstTitel = _

             "Sichern aller Module der Formatvorlagen aller geöffneten Dokumente"



    Dim docMyDoc              As Document   ' Alle Dokus durchgehen

    Dim strMeinPfad           As String     ' zum Speichern der Module

    Dim templateMyNormalDot   As Template   ' erstes Template: normal.dot

    Dim strAlleTemplates      As String     ' Mini LookUp-Tabelle

    Dim intI                  As Integer    ' Zähler

    Dim strBasePath           As String     ' Ausgangspfad

    Dim strMeldung            As String     ' für die Ausgabe

    

    

    strBasePath = Trim(strConstBasePath)

    If Right(strBasePath, 1) <> "\" Then

        strBasePath = strBasePath & "\"

    End If

    

    ' Ggf. Abbruch

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

        strMeldung = "Abbruch: Base Path existiert nicht:   " & _

                     strBasePath

        MsgBox strMeldung, _

               vbCritical, _

               "Fehler in: " & strConstTitel

        End 'Abbruch

    End If

    

    strBasePath = strBasePath & "AutoExport"

    strMeinPfad = ""

    ErstellePfad strBasePath, strMeinPfad

    

    ' Ggf. Abbruch

    If strMeinPfad = "" Or _

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

        strMeldung = "Das Verzeichnis mit dem Namen " & _

                     vbNewLine & _

                     strMeinPfad & _

                     vbNewLine & _

                     " existiert nicht. Deshalb Abbruch."

        MsgBox strMeldung, _

               vbCritical, _

               "Fehler in: " & strConstTitel

        End 'Abbruch

    End If

    

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

    ModuleExportieren templateMyNormalDot, _

                      replace(templateMyNormalDot.Name, ".", "_"), _

                      strMeinPfad

    ' Zum # s.o.

    strAlleTemplates = strAlleTemplates & _

                       "#" & templateMyNormalDot & "#"

    

    ' Schleife

    For Each docMyDoc In Application.Documents

        

        ' Zum # s.o.

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

            ModuleExportieren docMyDoc.AttachedTemplate, _

                              replace(docMyDoc.AttachedTemplate.Name, ".", "_"), _

                              strMeinPfad

            ' Zum # s.o.

            strAlleTemplates = strAlleTemplates & "#" & _

                               docMyDoc.AttachedTemplate.Name & _

                               "#"

            ' Zähler erhöhen

            intI = intI + 1

        End If

    

    Next docMyDoc



    ' Meldung

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

    ' das # wieder entfernen)

    strMeldung = "Fertig." & _

           vbNewLine & _

           "Pfad war:  " & _

           vbNewLine & _

           strMeinPfad & _

           "." & _

           vbNewLine & _

           "Templates waren: " & _

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

           vbNewLine & "Gesichert: " & _

           intI + 1 & " (mit normal.dot)." & _

           vbNewLine & _

           "Anzahl der Dokumente: " & _

           Application.Documents.Count & _

           "."

           

    MsgBox strMeldung, _

           vbInformation, _

           strConstTitel

    

    Shell "explorer /e," & strMeinPfad, _

          vbMaximizedFocus

        

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 'Abbruch

    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 & _

                                  SetzeTyp(vbcMeinVBComponent)

    

    Next vbcMeinVBComponent

    

End Sub



Private Function SetzeTyp(oKomponente As VBComponent) As String

    

    ' Dateityp erstellen

    

    Select Case oKomponente.Type

        Case vbext_ct_ClassModule

            SetzeTyp = ".cls"

        Case vbext_ct_MSForm

            SetzeTyp = ".frm"

        Case Else

            SetzeTyp = ".bas"

    End Select

    

End Function





' Für VB5 (Word 97):

'Private Function replace(sText As String, _

'                         vSuche As Variant, _

'                         VErsetze As Variant) _

'                              As String

'

'    Dim I   As Integer

'    Dim S   As String

'

'

'    For I = 1 To Len(sText)

'

'        S = Mid(sText, I, 1)

'

'        If S = vSuche Then

'            replace = replace & VErsetze

'        Else

'            replace = replace & S

'        End If

'

'    Next I

'

'End Function







Code eingefügt mit Syntaxhighlighter 2.5





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: