asked on

PPT CONVERSION TO PDF WITH WATERMARK

DEAR TEAM ,

I have the below code which saves my powerpoint in pdf format . However I am looking to punch a water mark of the below mentioned details.

If its possible please help me to incorporate the code.

POSITION

LEFT-239
TOP- 242
HEIGHT-73
WIDTH- 363

TEXT - "DRAFT REPORT"

CALIBRI- 54

RGB 159 159 159

ANGLE 45 DEGREEE

Sub PowerPointExportPDF()


Dim CurrentFolder As String
Dim FileName As String
Dim myPath As String
Dim UniqueName As Boolean

UniqueName = False


  myPath = ActivePresentation.FullName
  CurrentFolder = ActivePresentation.Path & "\"
  FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
   InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)


  Do While UniqueName = False
    DirFile = CurrentFolder & FileName & ".pdf"
    If Len(Dir(DirFile)) <> 0 Then
      UserAnswer = MsgBox("File Already Exists! Click " & _
       "[Yes] to override. Click [No] to Rename.", vbYesNoCancel)
      
      If UserAnswer = vbYes Then
        UniqueName = True
      ElseIf UserAnswer = vbNo Then
        Do
       
            FileName = InputBox("Provide New File Name " & _
             "(will ask again if you provide an invalid file name)", _
             "Enter File Name", FileName)
            
       
            If FileName = "False" Or FileName = "" Then Exit Sub
        Loop While ValidFileName(FileName) = False
      Else
        Exit Sub
      End If
    Else
      UniqueName = True
    End If
  Loop
   

  On Error GoTo ProblemSaving
    ActivePresentation.ExportAsFixedFormat CurrentFolder & FileName & ".pdf", _
      ppFixedFormatTypePDF, ppFixedFormatIntentPrint, msoCTrue, ppPrintHandoutHorizontalFirst, _
      ppPrintOutputSlides, msoFalse, , ppPrintAll, , False, False, False, False, False
  On Error GoTo 0
  

  With ActivePresentation
  FolderName = Mid(.Path, InStrRev(.Path, "\") + 1, Len(.Path) - InStrRev(.Path, "\"))
  End With
  
  MsgBox "PDF Saved in the Folder: " & FolderName

Exit Sub


ProblemSaving:
  MsgBox "There was a problem saving your PDF. This is most commonly caused " & _
   "by the original PDF file already being open."
  Exit Sub

End Sub


Function ValidFileName(FileName As Variant) As Boolean

Dim ppt As Presentation


  On Error GoTo InvalidFileName
    Set ppt = Presentations.Add
    ppt.SaveAs Environ("TEMP") & "\" & FileName & ".ppt", ppSaveAsPresentation
  On Error Resume Next


  ppt.Close


  Kill Environ("TEMP") & "\" & FileName & ".ppt"

  ValidFileName = True

Exit Function

InvalidFileName:

    ppt.Close
  

    ValidFileName = False

End Function

Open in new window

Daniel Pineault

You could try something along the lines of

Sub PowerPointExportPDF()
    Dim CurrentFolder         As String
    Dim FileName              As String
    Dim myPath                As String
    Dim UniqueName            As Boolean

    UniqueName = False

    myPath = ActivePresentation.FullName
    CurrentFolder = ActivePresentation.Path & "\"
    FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
                   InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)

    Do While UniqueName = False
        DirFile = CurrentFolder & FileName & ".pdf"
        If Len(Dir(DirFile)) <> 0 Then
            UserAnswer = MsgBox("File Already Exists! Click " & _
                                "[Yes] to override. Click [No] to Rename.", vbYesNoCancel)

            If UserAnswer = vbYes Then
                UniqueName = True
            ElseIf UserAnswer = vbNo Then
                Do
                    FileName = InputBox("Provide New File Name " & _
                                        "(will ask again if you provide an invalid file name)", _
                                        "Enter File Name", FileName)
                    If FileName = "False" Or FileName = "" Then Exit Sub
                Loop While ValidFileName(FileName) = False
            Else
                Exit Sub
            End If
        Else
            UniqueName = True
        End If
    Loop

    On Error GoTo ProblemSaving
    AddWaterMark
    DoEvents
    ActivePresentation.ExportAsFixedFormat CurrentFolder & FileName & ".pdf", _
                                           ppFixedFormatTypePDF, ppFixedFormatIntentPrint, msoCTrue, ppPrintHandoutHorizontalFirst, _
                                           ppPrintOutputSlides, msoFalse, , ppPrintAll, , False, False, False, False, False
    DoEvents
    RemoveWaterMark
    On Error GoTo 0

    With ActivePresentation
        FolderName = Mid(.Path, InStrRev(.Path, "\") + 1, Len(.Path) - InStrRev(.Path, "\"))
    End With

    MsgBox "PDF Saved in the Folder: " & FolderName
    Exit Sub

ProblemSaving:
    MsgBox "There was a problem saving your PDF. This is most commonly caused " & _
           "by the original PDF file already being open."
    Exit Sub
End Sub


Function ValidFileName(FileName As Variant) As Boolean
    Dim ppt                   As Presentation

    On Error GoTo InvalidFileName
    Set ppt = Presentations.Add
    ppt.SaveAs Environ("TEMP") & "\" & FileName & ".ppt", ppSaveAsPresentation
    On Error Resume Next


    ppt.Close

    Kill Environ("TEMP") & "\" & FileName & ".ppt"

    ValidFileName = True
    Exit Function

InvalidFileName:
    ppt.Close
    ValidFileName = False
End Function

Function AddWaterMark()
' https://docs.microsoft.com/en-us/office/vba/api/powerpoint.shapes.addtextbox
' https://docs.microsoft.com/en-us/office/vba/api/powerpoint.shape.rotation
    Dim x                     As Long
    Dim oSh                   As Shape

    With ActivePresentation
        ' On each slidemaster in the presentation
        For x = 1 To .Designs.Count
            Set oSh = .Designs(1).SlideMaster.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                                                      239, _
                                                      242, _
                                                      363, _
                                                      73)

            oSh.Name = "WaterMark"
            oSh.Rotation = -45
            With oSh.TextFrame.TextRange
                .Font.Name = "CALIBRI"
                .Font.Size = 54
                .Text = "DRAFT REPORT"
                .Font.Color = RGB(159, 159, 159)
            End With
        Next
    End With
End Function

Function RemoveWaterMark()
    Dim x                     As Long
    Dim oSh                   As Shape

    With ActivePresentation
        ' On each slidemaster in the presentation
        For x = 1 To .Designs.Count
            Set oSh = .Designs(1).SlideMaster.Shapes("WaterMark")
            oSh.Delete
        Next
    End With
End Function

Open in new window

Paul Sauvé

seems to me that this is more trouble than

copy the presentation
create a new slide master with the text exactly how you want it
apply it to the presentation
save as PDF

Stamps.ppt

amandeep kaur

ASKER

Hi daniel,

The code works fine , but I want to display the Draft report on Front of the slides . As it is hiding between the text . Would it be possible to "Bring the text Box into Front"

Thanks

Daniel Pineault

Not sure.

I would have thought

oSh.ZOrder (msoBringToFront)

Open in new window

would work, but it seems to not make any change whatsoever.

Daniel Pineault

This seems to do the job.

Sub PowerPointExportPDF()
    Dim CurrentFolder         As String
    Dim FileName              As String
    Dim myPath                As String
    Dim UniqueName            As Boolean

    UniqueName = False

    myPath = ActivePresentation.FullName
    CurrentFolder = ActivePresentation.Path & "\"
    FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
                   InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)

    Do While UniqueName = False
        DirFile = CurrentFolder & FileName & ".pdf"
        If Len(Dir(DirFile)) <> 0 Then
            UserAnswer = MsgBox("File Already Exists! Click " & _
                                "[Yes] to override. Click [No] to Rename.", vbYesNoCancel)

            If UserAnswer = vbYes Then
                UniqueName = True
            ElseIf UserAnswer = vbNo Then
                Do
                    FileName = InputBox("Provide New File Name " & _
                                        "(will ask again if you provide an invalid file name)", _
                                        "Enter File Name", FileName)
                    If FileName = "False" Or FileName = "" Then Exit Sub
                Loop While ValidFileName(FileName) = False
            Else
                Exit Sub
            End If
        Else
            UniqueName = True
        End If
    Loop

    On Error GoTo ProblemSaving
    AddWaterMark
    DoEvents
    ActivePresentation.ExportAsFixedFormat CurrentFolder & FileName & ".pdf", _
                                           ppFixedFormatTypePDF, ppFixedFormatIntentPrint, msoCTrue, ppPrintHandoutHorizontalFirst, _
                                           ppPrintOutputSlides, msoFalse, , ppPrintAll, , False, False, False, False, False
    DoEvents
    RemoveWaterMark
    On Error GoTo 0

    With ActivePresentation
        FolderName = Mid(.Path, InStrRev(.Path, "\") + 1, Len(.Path) - InStrRev(.Path, "\"))
    End With

    MsgBox "PDF Saved in the Folder: " & FolderName
    Exit Sub

ProblemSaving:
    MsgBox "There was a problem saving your PDF. This is most commonly caused " & _
           "by the original PDF file already being open."
    Exit Sub
End Sub


Function ValidFileName(FileName As Variant) As Boolean
    Dim ppt                   As Presentation

    On Error GoTo InvalidFileName
    Set ppt = Presentations.Add
    ppt.SaveAs Environ("TEMP") & "\" & FileName & ".ppt", ppSaveAsPresentation
    On Error Resume Next


    ppt.Close

    Kill Environ("TEMP") & "\" & FileName & ".ppt"

    ValidFileName = True
    Exit Function

InvalidFileName:
    ppt.Close
    ValidFileName = False
End Function

Function AddWaterMark()
    Dim x                     As Long
    Dim i                     As Long
    Dim oSh                   As Shape
    Dim oShp                   As Shape

    With ActivePresentation
        ' On each slidemaster in the presentation
        For x = 1 To .Slides.Count
            Set oSh = .Slides(x).Shapes.AddTextbox(msoTextOrientationHorizontal, _
                                                      239, _
                                                      242, _
                                                      363, _
                                                      73)

            oSh.Name = "WaterMark"
            oSh.Rotation = -45
            With oSh.TextFrame.TextRange
                .Font.Name = "CALIBRI"
                .Font.Size = 54
                .Text = "DRAFT REPORT"
                .Font.Color = RGB(159, 159, 159)
            End With
            oSh.ZOrder (msoBringToFront)
        Next
    End With
End Function

Function RemoveWaterMark()
    Dim x                     As Long
    Dim oSh                   As Shape

    With ActivePresentation
        ' On each slidemaster in the presentation
        For x = 1 To .Slides.Count
            Set oSh = .Slides(x).Shapes("WaterMark")
            oSh.Delete
        Next
    End With
End Function

Open in new window

amandeep kaur

ASKER

Hi Daniel,

Thanks for the code . In case if its possible please incorporate.

Transparency= 0.5

Apologies for not mentioning this requirement earlier.

Thanks

ASKER CERTIFIED SOLUTION

Daniel Pineault

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial