title image


Smiley Neuer VBA-Code: Alle Module aus Ordner importieren


Man kann das ganze auch umkehren und

alle importierten Module in eine

neue Dokumentenvorlage importieren.





' Er braucht im VBA-Editor

' im Menü Extras | Verweise

' einen Verweis auf

' "Microsoft Visual Basic for Applications Extensibility 5.3"



Gruß, Christoph









Option Explicit



' Importiert einen kompletten Ordner (ohne *.frx) in VBA-Module.



' Word 2000

' Win XP / Win 2000



' Er braucht im VBA-Editor

' im Menü Extras | Verweise

' einen Verweis auf

' "Microsoft Visual Basic for Applications Extensibility 5.3"





' Stoppt oder crasht vielleicht bei problematischen

' Modulen (frx wird schon geblockt - was ist das?).





' Version mit wordinternen Dialogen.

' Liest über Dialog Pfade ein.

'

' Code z.T. von

' http://mypage.bluewin.ch/reprobst/WordFAQ/Browse.htm#Browse4

' und anderen Passagen auf mypage.bluewin.ch übernommen

' (z.B. DateinameAllokierenUndFensterBenennen).

'

'

' Die Daten der Dateien, welche sich im nominierten Verzeichnis befinden,

' werden importiert.





'**** Anfang des anpassbaren Teils *****

Private Const strTitel = "Module Importieren"                      ' Der Titel

Private Const constVerzeichnis1 = "C:\Dokumente und Einstellungen" ' Für den Dialog

Private Const Hinweis1 = "Bitte wählen Sie den Quellordner aus:"   ' Erscheint wörtlich im Dialog

Private Const Dateierweiterung = "*"                               ' Welche Dateien suchen?

'**** Ende des anzupassenden Teils *****



' ***************************************************************************

' Hauptprozedur



Public Sub subModuleImportieren()

        

    Dim intI                 As Integer

    Dim strDateiAusSchleife  As String

    Dim strQuellVerzeichnis  As String

    

    

    ' Einlesen

    strQuellVerzeichnis = OrdnerAuswaehlen(Hinweis1, constVerzeichnis1)

    

    ' Ggf. Abbruch I.

    If strQuellVerzeichnis = "" Then

        MsgBox "Abbruch gewünscht", _

               vbInformation, _

               strTitel

        End

    End If

    

    ' Ggf. Abbruch II.

    If Dir(strQuellVerzeichnis & "\") = "" Then

        MsgBox "Das Verzeichnis mit dem Namen " & strQuellVerzeichnis & _

               " existiert nicht.", _

               vbCritical, _

               strTitel

        End

    End If

    

    ' Neue Dokumentenvorlage anlegen

    Documents.Add newtemplate:=True, Visible:=True

    Selection.TypeText "Am " & Format(Date, "Long Date") & _

                       " um " & Time & " aus " & _

                       vbNewLine & _

                       strQuellVerzeichnis & "." & vbNewLine & vbNewLine

    Selection.EndKey Unit:=wdStory, Extend:=wdMove

    

    DateinameAllokierenUndFensterBenennen "AusAutoExport"

    

    Application.CustomizationContext = ActiveDocument

    

    ' Mit einer Schleife alle Dateien des Ordners durchgehen:

    intI = 0

    strDateiAusSchleife = Dir(strQuellVerzeichnis & "\*" & Dateierweiterung)

    

    While Not strDateiAusSchleife = ""

        

        If Right(strDateiAusSchleife, 3) <> "frx" Then

            intI = intI + 1

            ' Importieren

            ActiveDocument.VBProject.VBComponents.Import (strDateiAusSchleife)

            ' Dokumentieren

            Selection.TypeText "FileName:= " & _

                               strDateiAusSchleife

            Selection.EndKey Unit:=wdStory, Extend:=wdMove

            ' Text zwischen zwei eingefügten Modulen:

            Selection.TypeText vbNewLine & _

                               "_____________________________________" & _

                               vbNewLine & vbNewLine

        End If

        

        strDateiAusSchleife = Dir

    

    Wend

    

    Selection.HomeKey Unit:=wdStory, Extend:=wdMove

    

    ' Abschluss:

    MsgBox "Fertig: " & intI & _

           " Datei(en) importiert." & _

           vbNewLine & _

           "Bitte speichern Sie die neue Dokumentenvorlage.", _

           vbInformation, _

           strTitel

    

End Sub



' ***************************************************************************

' Hilfsprozeduren



Private Function OrdnerAuswaehlen(strLokalTitel1 As String, _

                                  Verzeichnis2 As String) _

                                         As String

    

      ' Diese Routine lässt Benutzer/in einen Ordner auswählen.

    

      Dim savEnv

      Dim Fehler

      Dim Ordner

      

        

      savEnv = Options.DefaultFilePath(wdCurrentFolderPath)

      OrdnerAuswaehlen = ""

      

      On Error Resume Next

      

      If Verzeichnis2 = "" Then Verzeichnis2 = "c:\"

      Application.ChangeFileOpenDirectory Verzeichnis2

      Fehler = Err.Number

      

      On Error GoTo 0

      

      If Fehler > 0 And Fehler <> 4172 Then

        MsgBox Err.Description, vbCritical, strLokalTitel1

        Exit Function

      End If

      

      With Dialogs(wdDialogCopyFile)

        

        Select Case .Display

        

          Case -1 ' Benutzer/in hat einen Ordner ausgewählt.

            Ordner = .Directory

            If Left(Ordner, 1) = Chr(34) Then

              Ordner = Mid(Ordner, 2, Len(Ordner) - 3) 'Drop quotes and back slash

            Else

              Ordner = Left(Ordner, Len(Ordner) - 1) 'Drop back slash

            End If

            OrdnerAuswaehlen = Ordner

            

          Case 0 ' Benutzer/in hat den Vorgang abgebrochen.

            OrdnerAuswaehlen = ""

            

          Case Else ' Programmfehler

            MsgBox "Fehler bei Case-Else", vbInformation, strLokalTitel1

            

        End Select

        

      End With

  

End Function



Private Sub DateinameAllokierenUndFensterBenennen(strTitel As String)

  

  Dim windowFenster     As Window

  

  

  With Dialogs(wdDialogFileSummaryInfo)

    .Title = strTitel

    .Execute

  End With



  For Each windowFenster In ActiveDocument.Windows

    windowFenster.Caption = strTitel

  Next

  

End Sub







Code eingefügt mit Syntaxhighlighter 2.5







geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: