Attribute VB_Name = "XL_Makros"
Option Explicit

Sub WDRegistryDemo()
    'Lesen und Schreiben eines beliebigen Registrierungswerts
    'mit Hilfe des System-Objekts von Word.
    '© 2000, Ralf Nebelo

    Dim objWD As Object
    Dim strAbschnitt As String
    Dim strSchlüssel As String
    Dim strVorgabe As String
    Dim strWert As String
    
    strAbschnitt = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion"
    strSchlüssel = "RegisteredOwner"
    
    Set objWD = CreateObject("Word.Application")
    If objWD Is Nothing Then
        MsgBox "Word kann nicht gestartet werden."
        Exit Sub
    End If
        
    With objWD
        strVorgabe = .System.PrivateProfileString(Filename:="", Section:=strAbschnitt, Key:=strSchlüssel)
        strWert = InputBox("Registrierter Windows-Besitzer:", "RegistryDemo", strVorgabe)
        If strWert > "" Then
            .System.PrivateProfileString(Filename:="", Section:=strAbschnitt, Key:=strSchlüssel) = strWert
        End If
    End With
        
    Set objWD = Nothing
End Sub

Sub WDSpardruck()
    'Öffnet die aktuelle Arbeitsmappe mit Word und druckt deren Inhalt
    'mit einer wählbaren Seitenzahl pro Blatt.
    '© 2000, Ralf Nebelo
    
    Dim objWD As Object
    Dim intWert As Integer
    Dim intCols As Integer
    Dim intRows As Integer
    Dim blnDrucken As Boolean
    Const wdOpenFormatAuto = 0

    With frmListenfeld
        .Caption = "Seiten pro Blatt"
        With .lstListe
            .Clear
            .AddItem "2 Seiten"
            .AddItem "4 Seiten"
            .AddItem "6 Seiten"
            .AddItem "8 Seiten"
            .AddItem "16 Seiten"
        End With
        
        .Show vbModal
        If .lstListe.Value > "" Then
            intWert = Val(.lstListe.Value)
            Select Case intWert
            Case 2
                intCols = 2
                intRows = 1
            Case 4, 6, 8
                intCols = intWert / 2
                intRows = 2
            Case 16
                intCols = 4
                intRows = 4
            End Select
            blnDrucken = True
        End If
    End With
    Unload frmListenfeld
    
    If blnDrucken = True Then
        Set objWD = CreateObject("Word.Application")
        If objWD Is Nothing Then
            MsgBox "Word kann nicht gestartet werden."
            Exit Sub
        End If
        
        With objWD
            .Visible = True
            .Activate
            SendKeys "{Enter}{Enter}"
            .Documents.Open Filename:=ActiveWorkbook.FullName, ConfirmConversions:=False, ReadOnly:=True, AddToRecentFiles:=False, Revert:=False, Format:=wdOpenFormatAuto
            .PrintOut Background:=False, PrintZoomColumn:=intCols, PrintZoomRow:=intRows
            .ActiveDocument.Close
            .Quit SaveChanges:=False
        End With
        
        Set objWD = Nothing
    End If
End Sub

Sub PPBildschirmschoner()
    'Erstellt eine neue PowerPoint-Präsentation aus sämtlichen Bilddateien
    'des Unterordners "Bilder" und einer im Dialog abgefragten Textnachricht.
    'Jedes Bild wird formatfüllend in eine eigene Folie eingefügt,
    'die im Verlauf der automatisch gestarteten Präsentation für jeweils
    '5 Sekunden auf dem Bildschirm bleibt. Die Folienwechsel und die Anzeige
    'der Textnachricht sind animiert.
    '© 2000, Ralf Nebelo
    
    Dim objPP As Object
    Dim strNachricht As String
    Dim strBildordner As String
    Dim vntBilddatei As Variant
    Dim objNeuePräsentation As Object
    Dim objNeueFolie As Object
    Dim objNeueGrafik As Object
    Dim objNeueTextbox As Object
    Dim intZufallszahl As Integer
    Const ppLayoutBlank = 12
    Const ppAlignRight = 3
    Const ppEffectRandom = 513
    Const ppAnimateByWord = 1
    Const ppAdvanceOnTime = 2
    Const ppTransitionSpeedFast = 3
    Const ppShowTypeSpeaker = 1
    
    strBildordner = ActiveWorkbook.Path & "\bilder"
    
    strNachricht = InputBox("Nachricht:", "Schöner schonen", "Komme gleich wieder...")
    If strNachricht = "" Then
        Exit Sub
    End If
    
    Set objPP = CreateObject("PowerPoint.Application")
    If objPP Is Nothing Then
        MsgBox "PowerPoint kann nicht gestartet werden."
        Exit Sub
    End If
    
    With objPP.FileSearch
        .Filename = "*.bmp;*.tif;*.gif;*.jpg"
        .LookIn = strBildordner
        .SearchSubFolders = False
        .Execute
        If .FoundFiles.Count > 0 Then
            Set objNeuePräsentation = objPP.Presentations.Add
            For Each vntBilddatei In .FoundFiles
                Set objNeueFolie = objNeuePräsentation.Slides.Add(Index:=objNeuePräsentation.Slides.Count + 1, Layout:=ppLayoutBlank)
                With objNeueFolie
                    .FollowMasterBackground = msoFalse
                    .Background.Fill.ForeColor.RGB = RGB(0, 0, 0)
                    
                    Set objNeueGrafik = .Shapes.AddPicture(Filename:=vntBilddatei, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=70, Height:=70)
                    With objNeueGrafik
                        .ScaleHeight 1, True
                        .ScaleWidth 1, True
                        .LockAspectRatio = True
                        If .Height > .Width Then
                            .Height = objNeuePräsentation.SlideMaster.Height
                            .Left = objNeuePräsentation.SlideMaster.Width / 2 - .Width / 2
                        Else
                            .Width = objNeuePräsentation.SlideMaster.Width
                            .Top = objNeuePräsentation.SlideMaster.Height / 2 - .Height / 2
                        End If
                    End With
                    
                    Set objNeueTextbox = objNeueFolie.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=0, Top:=0, Width:=objNeuePräsentation.SlideMaster.Width, Height:=48)
                    With objNeueTextbox
                        intZufallszahl = Int((2 * Rnd) + 1)
                        If intZufallszahl = 2 Then
                            .Top = objNeuePräsentation.SlideMaster.Height - 80
                        End If
                        
                        With .TextFrame.TextRange
                            intZufallszahl = Int((2 * Rnd) + 1)
                            If intZufallszahl = 2 Then
                                .ParagraphFormat.Alignment = ppAlignRight
                            End If
                            
                            .Text = strNachricht
                            With .Font
                                .Name = "Times New Roman"
                                .Size = 36
                                .Bold = True
                                .Shadow = True
                                .Color = vbWhite
                            End With
                        End With
                        
                        With .AnimationSettings
                            .Animate = True
                            .EntryEffect = ppEffectRandom 'ppEffectSwivel
                            .TextUnitEffect = ppAnimateByWord
                            .AdvanceMode = ppAdvanceOnTime
                            .AdvanceTime = 1
                        End With
                    End With
                    
                    With .SlideShowTransition
                        .EntryEffect = ppEffectRandom
                        .Speed = ppTransitionSpeedFast
                        .AdvanceOnClick = True
                        .AdvanceOnTime = True
                        .AdvanceTime = 5
                    End With
                End With
            Next
            
            With objNeuePräsentation.SlideShowSettings
                .ShowType = ppShowTypeSpeaker
                .LoopUntilStopped = True
                .Run
            End With
        End If
    End With

    Do While objPP.SlideShowWindows.Count > 0
        DoEvents
    Loop
    
    objPP.Quit
    Set objPP = Nothing
End Sub


