title image


Smiley Neue Version...
Neue Version

des Programms von eku, das ich aufgebohrt habe.



Gruß









Option Explicit



' Diese Routine druckt alle Module einer Dokumentenvorlage oder eines Dokumentes.

' Als erstes werden Sie aufgefordert, eine Vorlage oder ein Dokument zu öffnen.

'

' Benutzt für Syntaxhighlighting den Editor SciTE;

' siehe http://www.scintilla.org.

' Er muss installiert sein und der Pfad muss eingetragen werden.

'

' Word braucht im VBA-Editor

' im Menü Extras | Verweise

' einen Verweis auf

' "Microsoft Visual Basic for Applications Extensibility 5.3"

' und auf

' "Microsoft Forms 2.0. Object Library".

'

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

'

' Erstellt am 02/09/99 von René Probst / eku / CH-8152 Glattbrugg

'

'

' Erweitert am 07. Februar 2004

'

' Version: Version 2 vom 07. Februar 2004

'



Private Const asTitle = "VBA-Module drucken"

Private Assi As Boolean

Private asVisible As Boolean

Private oBlase As Balloon



Sub ModuleDrucken()



    Const strConstNameDummy = "c:\vbascitedummy1.txt"

    Const pathSciTe = "C:\Dokumente und Einstellungen\Eigene Dateien\wscite\SciTE.exe"

    

    Dim MyData          As DataObject

    Dim oDoc            As Document

    Dim rDoc            As Document

    Dim strDatei        As String

    Dim oAssistant

    Dim antwort

    Dim Anz

    Dim x

    Dim AnwID_SciTE

    

    

    strDatei = ""

    strDatei = Dir(pathSciTe)

    If strDatei = "" Then

        MsgBox "SciTe nicht gefunden. Abbruch.", _

               vbCritical, _

               asTitle

        End  ' Abbruch

    End If

    

    strDatei = ""

    strDatei = Dir(strConstNameDummy)

    If strDatei <> "" Then

        If MsgBox("Der Datei-Dummy existiert. " & _

                  "Dieser wird gelöscht. " & _

                  "Dennoch fortfahren?.", _

                  vbExclamation + vbYesNo, _

                  asTitle) = vbYes Then

            ' löschen

            Kill strConstNameDummy

        Else

            End  ' Abbruch

        End If

    End If

    

    Set MyData = New DataObject

    

    Set oAssistant = Assistant

    If Not oAssistant Is Nothing Then

      Assi = True

      asVisible = Assistant.Visible

      Assistant.Animation = msoAnimationGreeting

      antwort = BlaseAnzeigen

    Else

      Assi = False

    End If

    

    Set oAssistant = Nothing

    If antwort = -2 Then HappyEnd

    

    With Dialogs(wdDialogFileOpen)

      .Name = Options.DefaultFilePath(wdUserTemplatesPath) & "\"

      antwort = .Show

    End With

    

    If antwort = 0 Then HappyEnd

    Set oDoc = ActiveDocument

    Set rDoc = Documents.Add

    

    With Selection

      .TypeParagraph

      .TypeParagraph

      .TypeParagraph

    End With

    

    System.Cursor = wdCursorWait

    Application.ScreenUpdating = False

    Seiteeinrichten

    With Selection

     

      .EndKey Unit:=wdStory, Extend:=wdMove

      

      .LanguageID = wdNoProofing



      .Style = wdStyleHeading1

      .TypeText Text:="Module im Projekt " & oDoc.VBProject.Name & _

         " (" & oDoc.Name & ")" & vbCrLf

      Anz = 0

      

      If oDoc.VBProject.VBComponents.Count > 0 Then

          ' SciTe öffnen

          AnwID_SciTE = Shell(pathSciTe, vbHide + vbMinimizedFocus)

      End If

      

      For Each x In oDoc.VBProject.VBComponents

        If x.CodeModule.CountOfLines > 0 Then

          Anz = Anz + 1

          .Style = wdStyleHeading2

          .TypeText Text:=x.Name & " (" & EditType(x.Type) & ")" & vbCrLf

          RahmenHinzufügen 9, 9

          .Style = wdStyleMacroText

          

          ' alte Version: Modultext ohne Syntax-Highlighting

          ' .TypeText Text:=x.CodeModule.Lines(1, x.CodeModule.CountOfLines) & vbCrLf

          

          ' Text des aktuellen Moduls in die Zwischenablage

          MyData.SetText x.CodeModule.Lines(1, x.CodeModule.CountOfLines) & vbCrLf

          MyData.PutInClipboard

    

          ' SciTE steuern

          SteuerungVonSciTE AnwID_SciTE, strConstNameDummy

          

          ' zurück zum Word-Doku

          rDoc.Activate

          

          ' RTF einfügen

          Selection.Paste

          

          ' Rahmen

          RahmenHinzufügen 6, 45

        

        End If

      Next

      

      ' SciTe schliessen

      If oDoc.VBProject.VBComponents.Count > 0 Then

        AppActivate AnwID_SciTE, True

        ' SciTe schliessen

        SendKeys "%{F4}", True

      End If

      

      ' zurück zu Word

      Application.Activate

      

      .HomeKey Unit:=wdStory

      If Anz = 0 Then

        .Style = wdStyleNormal

        .Font.Italic = True

      End If

    

    End With

    

    ' Abschluss

    oDoc.Saved = True

    oDoc.Close

    rDoc.Activate

    rDoc.Content.NoProofing = True

    

    ErsetzeSchriftarten "Courier New", "Arial"

    ErsetzeSchriftarten "Times New Roman", "Arial"

    ErsetzeSchriftarten "Lucida Sans Unicode", "Arial"

    

    rDoc.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft

    

    If MsgBox("Fertig." & _

              vbNewLine & _

              "Wollen Sie jetzt drucken?", _

              vbQuestion + vbYesNo, _

              asTitle) = vbYes Then

        rDoc.PrintOut

    End If

    

    Assistant.Animation = msoAnimationCharacterSuccessMajor

    HappyEnd

    

End Sub



Private Sub Seiteeinrichten()



  Dim x

  

  

  With ActiveDocument.PageSetup

    .TopMargin = CentimetersToPoints(1.2)

    .BottomMargin = CentimetersToPoints(1.8)

    .LeftMargin = CentimetersToPoints(2.5)

    .RightMargin = CentimetersToPoints(1.2)

  End With

  ActiveWindow.ActivePane.View = wdPrintView

  ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter

  With Selection

    .ParagraphFormat.Alignment = wdAlignParagraphRight

    x = .Information(wdHorizontalPositionRelativeToTextBoundary)

    .ParagraphFormat.Alignment = wdAlignParagraphLeft

    .ParagraphFormat.TabStops.ClearAll

    .ParagraphFormat.TabStops.Add Position:=x, Alignment:=wdAlignTabRight

    .TypeText Text:="Stand: " & Format(Date, "d.mmm.yyyy") & vbTab

    .Fields.Add Range:=.Range, Type:=wdFieldPage

    .EndKey

    .TypeText Text:=" von "

    .EndKey

    .Fields.Add Range:=.Range, Type:=wdFieldNumPages

  End With

  With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary)

    .Range.Font.Name = "Arial"

  End With

  ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

End Sub



Private Sub RahmenHinzufügen(tvor, tnach)

  With Selection

    .Style = wdStyleNormal

    .Font.Size = 1

    With .ParagraphFormat

      .Space1

      .SpaceBefore = tvor

      .SpaceAfter = tnach

      With .Borders(wdBorderTop)

        .LineStyle = wdLineStyleSingle

        .LineWidth = wdLineWidth225pt

        .Color = wdColorGray75

      End With

    End With

    .TypeParagraph

  End With

End Sub



Private Function EditType(tType)

  

  Dim t

  

  

  Select Case tType

    Case 1: t = "Modul"

    Case 2: t = "Klassenmodul"

    Case 3: t = "UserForm"

    Case 100: t = "Objekt"

  End Select

  EditType = t

End Function



Private Function BlaseAnzeigen()

  Dim tmp

  Set oBlase = Assistant.NewBalloon

  With oBlase

    .Mode = msoModeModal

    .BalloonType = msoBalloonTypeButtons

    .Icon = msoIconTip

    .Heading = asTitle

    tmp = "Diese Routine druckt alle Module einer Dokumentenvorlage oder eines "

    tmp = tmp & "Dokumentes." & vbCrLf & vbCrLf & "Als erstes werden Sie "

    .Text = tmp & "aufgefordert, eine Vorlage oder ein Dokument zu öffnen."

    .Button = msoButtonSetOkCancel

    BlaseAnzeigen = .Show

  End With

End Function



Private Sub HappyEnd()

  Application.ScreenUpdating = True

  System.Cursor = wdCursorNormal

  If Assi = True Then Assistant.Visible = asVisible

  End

End Sub



Private Sub SteuerungVonSciTE(AnwID_SciTE, _

                              strConstNameDummy)

    

    Dim strDatei

    

    

    ' zu SciTe wechseln

    AppActivate AnwID_SciTE, True

    

    ' Text in SciTe einfügen (strg-v)

    SendKeys "^v", True

    

    ' SciTe: Im Menü language die Sprache wählen

    SendKeys "%l", True ' Alt-L

    SendKeys "v", True  ' v = vbasic

    

    ' SciTe: Alles markieren

    SendKeys "^a", True ' strg-a

    

    ' SciTe: Im Menü Edit "Copy as RTF" starten

    SendKeys "%e", True  ' Alt-E

    SendKeys "F", True   ' Copy as RTF

    SendKeys "{DELETE}", True   ' Copy as RTF

    

    ' SciTe: save (sonst fragt SciTe, ob man speichern will)

    SendKeys "^s", True ' strg-s

    ' SciTe: save: Name im Dialogfeld

    SendKeys strConstNameDummy, True

    ' SciTe: save: speichern-button im Dialogfeld

    SendKeys "%s", True

    

    ' SciTe: Doku schliessen

    SendKeys "^{F4}", True    ' Strg-F4

    

    ' Dummy löschen:

    strDatei = ""

    strDatei = Dir(strConstNameDummy)

    If strDatei <> "" Then

      Kill strConstNameDummy

    End If

    

    ' zurück zu Word

    Application.Activate

    

End Sub



Private Sub ErsetzeSchriftarten(SucheFont, ErsetzeFont)

' usage: ErsetzeSchriftarten "Courier New", "Arial"

'

' Makro am 07.02.2004

'

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = ""

        .Font.Name = SucheFont

        .Replacement.Text = ""

        .Replacement.Font.Name = ErsetzeFont

        .Forward = True

        .Wrap = wdFindContinue

        .Format = True

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute replace:=wdReplaceAll

End Sub



' (Druckt alle Module einer Dokumentvorlage oder eines Dokumentes aus.)







Code eingefügt mit Syntaxhighlighter 2.5





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: