title image


Smiley Version 2 zum Importieren
Version 2 zum Importieren



Word macht nur beim Importieren

von Forms Ärger. Sonst nummeriert Word sauber automatisch durch.



Gleichnamige (doppelte) Forms fange ich jetzt ab, bei anderen doppelten gibt es eine Warnung.



Die Prüfung auf doppelte ist wie von U.Miller vorgeschlagen als LookUp-tabelle realisiert, als string ausgeführt.



Ansonsten mit einigen Verbesserungen von U.Miller: FileSearch etc. (Danke!!).



Gruß, Christoph











Option Explicit



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



' Neue Version (Nr.2 vom 26.10.2003)



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



' Version mit wordinternem Dialog.

' Liest über Dialog Pfad 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 als Module importiert.





' Es gibt eine Mini LookUp-Tabelle strLookUpTabelle (ein string),

' die dazu dient, zu kontollieren, ob ein Modulname doppelt ist.

' Das führt zu einer Warnung (bei Doppelung) und nur bei Forms dazu,

' dass das zweite Vorkommen des Namens nicht importiert wird.

'

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

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

' 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 "modultest" würde bei testmodultestfuerRange

' [statt #testmodul#testfuerRange#]

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

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

' Daher das # bei instr etc.





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

Private Const strTitel = "Module Importieren"                      ' Der Titel

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

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



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

' Hauptprozedur



Public Sub subModuleImportieren()

        

    Dim intI                            As Integer

    Dim strQuellVerzeichnis             As String

    Dim intI_FileSearch                 As Integer

    Dim strLookUpTabelle                As String

    Dim strAusfsGetModulName            As String

    Dim strDatei                        As String

    

    

    ' Einlesen

    strQuellVerzeichnis = OrdnerAuswaehlen(strTitel, 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

    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



    With Application.FileSearch

    

        .NewSearch ' wichtig!

        .LookIn = strQuellVerzeichnis

        .SearchSubFolders = False

        .FileType = msoFileTypeAllFiles

        '.FileName = "*.*"  ' ggf. zusätzliche Einschränkung (hier nicht sinnvoll)

        .Execute

        If .FoundFiles.Count > 0 Then

            ' Schleife

            For intI_FileSearch = 1 To .FoundFiles.Count

            

                ' .FoundFiles(intI_FileSearch) enthält den kompletten Pfadnamen

                strDatei = .FoundFiles(intI_FileSearch)

                

                strAusfsGetModulName = fsGetModulName(strDatei, strLookUpTabelle)

                If strAusfsGetModulName <> "" Then

                    DateiAbarbeiten intI, _

                                    strLookUpTabelle, _

                                    strAusfsGetModulName, _

                                    strDatei

                End If

                

            Next intI_FileSearch

        End If

    End With

    

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

    

    ' Abschluss:

    MsgBox "Fertig: " & intI & _

           " Datei(en) importiert." & _

           vbNewLine & _

           "Bitte speichern Sie die neue Dokumentenvorlage. " & _

           "Log-File in der 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



Private Function fsGetModulName(strDatei As String, _

                                strLookUpTabelle As String) _

                                      As String

    

    Dim intFile   As Integer

    Dim strZeile  As String

    

    

    ' Init

    fsGetModulName = ""

    

    If Dir(strDatei) = "" Then Exit Function

'   If Dir(strDatei, vbDirectory) <> "" Then Exit Function

    

    ' Error-Handling mal außen vor lassen

    intFile = FreeFile

    Open strDatei For Input As #intFile

    

    Do While Not EOF(intFile)

        Line Input #intFile, strZeile

        If Left(strZeile, 21) = "Attribute VB_Name = " & Chr(34) Then

            fsGetModulName = Mid(strZeile, 22)

            fsGetModulName = Left(fsGetModulName, Len(fsGetModulName) - 1)

            Debug.Print strLookUpTabelle

            Exit Do

        End If

    Loop

    

    Close #intFile

    

End Function



Sub DateiAbarbeiten(intI As Integer, _

                    strLookUpTabelle As String, _

                    strAusfsGetModulName As String, _

                    strDatei As String)

    

    Dim boolFehlerMeldungWurdeGegeben   As Boolean

    Dim vbcMeinVBComponent              As VBComponent

    

    

    intI = intI + 1

    boolFehlerMeldungWurdeGegeben = False

    

    ' Dokumentieren

    Selection.TypeText "FileName: " & _

                       strDatei

                       

    ' Forms können als einziges nur einmal importiert werden:

    If InStr(1, _

             strLookUpTabelle, _

             "#" & strAusfsGetModulName & "#") <= 0 Or _

       Right(strDatei, _

             4) <> ".frm" _

       Then

        ' Importieren

        Set vbcMeinVBComponent = _

                ActiveDocument.VBProject.VBComponents.Import(strDatei)

        Selection.TypeText " [" & vbcMeinVBComponent.Name & _

                       ", " & _

                       vbcMeinVBComponent.CodeModule.CountOfLines & _

                       " Zeilen] "

        ' Bei anderen ausser Forms nur Warnung ausgeben bei Doppelung

        TestAufstrLookUpTabelle strLookUpTabelle, _

                                strAusfsGetModulName, _

                                boolFehlerMeldungWurdeGegeben, _

                                vbcMeinVBComponent.CodeModule.CountOfLines

        strLookUpTabelle = strLookUpTabelle & _

                           "#" & _

                           strAusfsGetModulName & _

                           "#"

    Else

        ' Fehlermeldung wenn es eine Form ist und

        ' sie schon vorhanden ist(strLookUpTabelle)

        boolFehlerMeldungWurdeGegeben = True

        MsgBox "Form " & strAusfsGetModulName & " wurde nicht importiert. " & _

               "Name existierte bereits.", _

               vbExclamation, _

               strTitel

        Selection.TypeText " Wurde nicht importiert."

        Selection.Paragraphs(1).Range.Bold = True

               

    End If

    

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

    ' Text zwischen zwei eingefügten Modulen:

    Selection.TypeText vbNewLine

    Selection.Paragraphs(1).Range.Bold = False

    Selection.TypeText "_____________________________________" & _

                       vbNewLine & vbNewLine



End Sub



Sub TestAufstrLookUpTabelle(strLookUpTabelle As String, _

                            strAusfsGetModulName As String, _

                            boolFehlerMeldungWurdeGegeben As Boolean, _

                            intAnzahlLines As Integer)

                    

    If InStr(1, _

             strLookUpTabelle, _

             "#" & strAusfsGetModulName & "#") > 0 Then

             

        If boolFehlerMeldungWurdeGegeben = False Then

            

            MsgBox strAusfsGetModulName & _

                   " wird doppelt importiert. " & _

                   "Mehrere ThisDocument werden von Word automatisch " & _

                   "durchnummeriert und unter Klassenmodul gespeichert; " & _

                   "sonst nummeriert Word die gleichnamigen Module " & _

                   "automatisch " & _

                   "durch (Forms werden nur einmal geladen (!)). " & _

                   " Anzahl der Zeilen war (bei diesem 2. Mal): " & _

                   intAnzahlLines & ".", _

                   vbExclamation, _

                   strTitel

            

            Selection.TypeText "Doppelung"

            Selection.Paragraphs(1).Range.Bold = False

            

        End If

        

    End If

    

End Sub







Code eingefügt mit Syntaxhighlighter 2.5





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: