none
PDF file save with company name RRS feed

  • Question

  • Dear experts

    below mention code, i am using for separate the word file than export to pdf and saving on my desired place. i need amended in that i want to save each sheet with company name which in sheet after "TO"

    https://www.dropbox.com/s/hqxjy1ezq9tzw12/Sample.docm?dl=0

    pl make amend like this if i change format or paragraph code should be work but company name always be there...!!means it should follow first "TO", some time date we made on top or some other reference number & sometime these are not there..!!

    Option Explicit
    Sub SaveAsSeparatePDFs()
    
    Dim strDirectory As String, strTemp As String
    Dim ipgStart As Integer, ipgEnd As Integer
    Dim iPDFnum As Integer, i As Integer
    Dim vMsg As Variant, bError As Boolean
      
    1:
    strDirectory = InputBox("Directory to save individual PDFs? " & _
        vbNewLine & "(ex: C:\Users\Public)")
    If strDirectory = "" Then Exit Sub
    If Dir(strDirectory, vbDirectory) = "" Then
        vMsg = MsgBox("Please enter a valid directory.", vbOKCancel, "Invalid Directory")
        If vMsg = 1 Then
            GoTo 1
        Else
            Exit Sub
        End If
    End If
    
    2:
    strTemp = InputBox("Begin saving PDFs starting with page __? " & _
        vbNewLine & "(ex: 32)")
    bError = bErrorF(strTemp)
    If bError = True Then GoTo 2
    ipgStart = CInt(strTemp)
    
    3:
    strTemp = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 37)")
    bError = bErrorF(strTemp)
    If bError = True Then GoTo 3
    ipgEnd = CInt(strTemp)
     
    iPDFnum = ipgStart
    On Error GoTo 4:
    For i = ipgStart To ipgEnd
        ActiveDocument.ExportAsFixedFormat OutputFileName:= _
            strDirectory & "\Page_" & iPDFnum & ".pdf", ExportFormat:=wdExportFormatPDF, _
            OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
            wdExportFromTo, From:=i, To:=i, Item:=wdExportDocumentContent, _
            IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _
            wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
            BitmapMissingFonts:=False, UseISO19005_1:=False
        iPDFnum = iPDFnum + 1
    Next i
    End
    4:
    vMsg = MsgBox("Unknown error encountered while creating PDFs." & vbNewLine & vbNewLine & _
        "Aborting", vbCritical, "Error Encountered")
    End Sub
    
    Private Function bErrorF(strTemp As String) As Boolean
    Dim i As Integer, vMsg As Variant
    bErrorF = False
    
    If strTemp = "" Then
        End
    ElseIf IsNumeric(strTemp) = True Then
        i = CInt(strTemp)
        If i > ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) Or i <= 0 Then
            Call msgS(bErrorF)
        End If
    Else
        Call msgS(bErrorF)
    End If
    End Function
    
    Private Sub msgS(bMsg As Boolean)
    Dim vMsg As Variant
        vMsg = MsgBox("Please enter a valid integer." & vbNewLine & vbNewLine & _
            "Integer must be > 0 and < total pages in the document (" & _
            ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) & ")", vbOKCancel, "Invalid Integer")
        If vMsg = 1 Then
            bMsg = True
        Else
            End
        End If
    End Sub
    
    

    Adeel


    • Edited by Adeeeel Friday, February 24, 2017 7:31 PM
    Friday, February 24, 2017 7:30 PM

Answers

  • Option Explicit
    Sub SaveAsSeparatePDFs()
    
    Dim strDirectory As String, strTemp As String
    Dim ipgStart As Integer, ipgEnd As Integer
    Dim iPDFnum As Integer, i As Integer
    Dim vMsg As Variant, bError As Boolean
      
    1:
    strDirectory = InputBox("Directory to save individual PDFs? " & _
        vbNewLine & "(ex: C:\Users\Public)")
    If strDirectory = "" Then Exit Sub
    If Dir(strDirectory, vbDirectory) = "" Then
        vMsg = MsgBox("Please enter a valid directory.", vbOKCancel, "Invalid Directory")
        If vMsg = 1 Then
            GoTo 1
        Else
            Exit Sub
        End If
    End If
    
    2:
    strTemp = InputBox("Begin saving PDFs starting with page __? " & _
        vbNewLine & "(ex: 32)")
    bError = bErrorF(strTemp)
    If bError = True Then GoTo 2
    ipgStart = CInt(strTemp)
    Dim companyName As String
    companyName = getFirstCompanyName(ipgStart)
    3:
    strTemp = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 37)")
    bError = bErrorF(strTemp)
    If bError = True Then GoTo 3
    ipgEnd = CInt(strTemp)
     
    iPDFnum = ipgStart
    On Error GoTo 4:
    For i = ipgStart To ipgEnd
        ActiveDocument.ExportAsFixedFormat OutputFileName:= _
            strDirectory & companyName & "\Page_" & iPDFnum & ".pdf", ExportFormat:=wdExportFormatPDF, _
            OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
            wdExportFromTo, From:=i, To:=i, Item:=wdExportDocumentContent, _
            IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _
            wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
            BitmapMissingFonts:=False, UseISO19005_1:=False
        iPDFnum = iPDFnum + 1
    Next i
    End
    4:
    vMsg = MsgBox("Unknown error encountered while creating PDFs." & vbNewLine & vbNewLine & _
        "Aborting", vbCritical, "Error Encountered")
    End Sub
    
    Private Function bErrorF(strTemp As String) As Boolean
    Dim i As Integer, vMsg As Variant
    bErrorF = False
    
    If strTemp = "" Then
        End
    ElseIf IsNumeric(strTemp) = True Then
        i = CInt(strTemp)
        If i > ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) Or i <= 0 Then
            Call msgS(bErrorF)
        End If
    Else
        Call msgS(bErrorF)
    End If
    End Function
    
    Private Sub msgS(bMsg As Boolean)
    Dim vMsg As Variant
        vMsg = MsgBox("Please enter a valid integer." & vbNewLine & vbNewLine & _
            "Integer must be > 0 and < total pages in the document (" & _
            ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) & ")", vbOKCancel, "Invalid Integer")
        If vMsg = 1 Then
            bMsg = True
        Else
            End
        End If
    End Sub
    
    Function getFirstCompanyName(ipgStart As Integer) As String
    Selection.GoTo wdGoToPage, wdGoToAbsolute, ipgStart
       Selection.Find.ClearFormatting
        Selection.Find.Text = "To"
        Selection.Find.Execute
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1
        getFirstCompanyName = Selection.Paragraphs(1).Range.Text
    End Function
    
    


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by Adeeeel Thursday, March 2, 2017 5:27 AM
    Sunday, February 26, 2017 9:07 AM
    Moderator
  • Hi,

    If so, please use

    strDirectory & "\" & Replace(getFirstCompanyName(iPDFnum), Chr(13), "") & "_Page_" & iPDFnum & ".pdf"

    It could save each file using their company name with page number.

    If you just want the company name without page number, please use

    strDirectory & "\" & Replace(getFirstCompanyName(iPDFnum), Chr(13), "") & ".pdf"

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by Adeeeel Thursday, March 2, 2017 5:27 AM
    Sunday, February 26, 2017 10:28 AM
    Moderator
  • Hello,

    Please check the code below. It uses regex to replace \ / ? < > \ : * | " into "."

    For i = ipgStart To ipgEnd Dim CName As String
    Dim reg As Object

    CName = Replace(getFirstCompanyName(iPDFnum), Chr(13), "")
    Set reg = CreateObject("VBScript.RegExp")
    reg.IgnoreCase = True
    reg.Global = True
    reg.Pattern = "[><\\\/\*\?:|""]"
    CName = reg.Replace(CName, ".") ActiveDocument.ExportAsFixedFormat OutputFileName:= _ strDirectory & "\" & CName & ".pdf", ExportFormat:=wdExportFormatPDF, _ OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _ wdExportFromTo, From:=i, To:=i, Item:=wdExportDocumentContent, _ IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _ wdExportCreateHeadingBookmarks, DocStructureTags:=True, _ BitmapMissingFonts:=False, UseISO19005_1:=False iPDFnum = iPDFnum + 1 Next i

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    Wednesday, March 1, 2017 9:47 AM
    Moderator

All replies

  • Hi,

    Please test the following code to get company name from starting page.

    Function getFirstCompanyName(ipgStart As Integer) As String
    Selection.GoTo wdGoToPage, wdGoToAbsolute, ipgStart
       Selection.Find.ClearFormatting
        Selection.Find.Text = "To"
        Selection.Find.Execute
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1
        getFirstCompanyName = Selection.Paragraphs(1).Range.Text
    End Function

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Sunday, February 26, 2017 6:32 AM
    Moderator
  • Dear sir

    where i need to put this code or it need to be run separately.??means that it wil run seperately of it will adjust with  above code..pl guide

    i want pdf copy save with company name..

    Adeel 


    • Edited by Adeeeel Sunday, February 26, 2017 7:15 AM
    Sunday, February 26, 2017 7:07 AM
  • Hi,

    After copying the function, call it in your sub like:

    2:
    strTemp = InputBox("Begin saving PDFs starting with page __? " & _
        vbNewLine & "(ex: 32)")
    bError = bErrorF(strTemp)
    If bError = True Then GoTo 2
    ipgStart = CInt(strTemp)
    Dim companyName As String
    companyName = getFirstCompanyName(ipgStart)
    3:
    strTemp = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 37)")
    bError = bErrorF(strTemp)
    If bError = True Then GoTo 3
    ipgEnd = CInt(strTemp)
     
    iPDFnum = ipgStart
    On Error GoTo 4:
    For i = ipgStart To ipgEnd
        ActiveDocument.ExportAsFixedFormat OutputFileName:= _
            strDirectory & companyName & "\Page_" & iPDFnum & ".pdf", ExportFormat:=wdExportFormatPDF, _
            OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
            wdExportFromTo, From:=i, To:=i, Item:=wdExportDocumentContent, _
            IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _
            wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
            BitmapMissingFonts:=False, UseISO19005_1:=False
        iPDFnum = iPDFnum + 1
    Next i
    End


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    Sunday, February 26, 2017 7:40 AM
    Moderator
  • sir totally lost,

    i tried to adjust code but failed, please give me adjusted code..?? Adeel



    • Edited by Adeeeel Sunday, February 26, 2017 8:18 AM
    Sunday, February 26, 2017 8:15 AM
  • Option Explicit
    Sub SaveAsSeparatePDFs()
    
    Dim strDirectory As String, strTemp As String
    Dim ipgStart As Integer, ipgEnd As Integer
    Dim iPDFnum As Integer, i As Integer
    Dim vMsg As Variant, bError As Boolean
      
    1:
    strDirectory = InputBox("Directory to save individual PDFs? " & _
        vbNewLine & "(ex: C:\Users\Public)")
    If strDirectory = "" Then Exit Sub
    If Dir(strDirectory, vbDirectory) = "" Then
        vMsg = MsgBox("Please enter a valid directory.", vbOKCancel, "Invalid Directory")
        If vMsg = 1 Then
            GoTo 1
        Else
            Exit Sub
        End If
    End If
    
    2:
    strTemp = InputBox("Begin saving PDFs starting with page __? " & _
        vbNewLine & "(ex: 32)")
    bError = bErrorF(strTemp)
    If bError = True Then GoTo 2
    ipgStart = CInt(strTemp)
    Dim companyName As String
    companyName = getFirstCompanyName(ipgStart)
    3:
    strTemp = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 37)")
    bError = bErrorF(strTemp)
    If bError = True Then GoTo 3
    ipgEnd = CInt(strTemp)
     
    iPDFnum = ipgStart
    On Error GoTo 4:
    For i = ipgStart To ipgEnd
        ActiveDocument.ExportAsFixedFormat OutputFileName:= _
            strDirectory & companyName & "\Page_" & iPDFnum & ".pdf", ExportFormat:=wdExportFormatPDF, _
            OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
            wdExportFromTo, From:=i, To:=i, Item:=wdExportDocumentContent, _
            IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _
            wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
            BitmapMissingFonts:=False, UseISO19005_1:=False
        iPDFnum = iPDFnum + 1
    Next i
    End
    4:
    vMsg = MsgBox("Unknown error encountered while creating PDFs." & vbNewLine & vbNewLine & _
        "Aborting", vbCritical, "Error Encountered")
    End Sub
    
    Private Function bErrorF(strTemp As String) As Boolean
    Dim i As Integer, vMsg As Variant
    bErrorF = False
    
    If strTemp = "" Then
        End
    ElseIf IsNumeric(strTemp) = True Then
        i = CInt(strTemp)
        If i > ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) Or i <= 0 Then
            Call msgS(bErrorF)
        End If
    Else
        Call msgS(bErrorF)
    End If
    End Function
    
    Private Sub msgS(bMsg As Boolean)
    Dim vMsg As Variant
        vMsg = MsgBox("Please enter a valid integer." & vbNewLine & vbNewLine & _
            "Integer must be > 0 and < total pages in the document (" & _
            ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) & ")", vbOKCancel, "Invalid Integer")
        If vMsg = 1 Then
            bMsg = True
        Else
            End
        End If
    End Sub
    
    Function getFirstCompanyName(ipgStart As Integer) As String
    Selection.GoTo wdGoToPage, wdGoToAbsolute, ipgStart
       Selection.Find.ClearFormatting
        Selection.Find.Text = "To"
        Selection.Find.Execute
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1
        getFirstCompanyName = Selection.Paragraphs(1).Range.Text
    End Function
    
    


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by Adeeeel Thursday, March 2, 2017 5:27 AM
    Sunday, February 26, 2017 9:07 AM
    Moderator
  • dear sir


    showing below error 


    • Edited by Adeeeel Sunday, February 26, 2017 9:18 AM
    Sunday, February 26, 2017 9:14 AM
  • Please test the code below and check if it could return the correct company name.

    Sub test()
    Dim companyName As String
    Dim ipgStart As Integer
    ipgStart = InputBox("starting with page __? " & _
        vbNewLine & "(ex: 32)")
    companyName = getFirstCompanyName(ipgStart)
    MsgBox (companyName)
    End Sub


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    Sunday, February 26, 2017 9:21 AM
    Moderator
  • dear sir 

    my first code is running quite perfectly but that is saving files page_1,page_2 so on..there is no issue in my first code

    adeel

    Sunday, February 26, 2017 9:27 AM
  • Hi,

    Please change line

     strDirectory & companyName & "\Page_" & iPDFnum & ".pdf"

    Into

    strDirectory & "\" & companyName & "_Page_" & iPDFnum & ".pdf"

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Sunday, February 26, 2017 9:32 AM
    Moderator
  • sir

    i changed the code with said code, still showing same error..

    find below link, with code which i shared and sheet,which is running correctly for more understanding

    https://www.dropbox.com/s/hqxjy1ezq9tzw12/Sample.docm?dl=0

    Adeel



    • Edited by Adeeeel Sunday, February 26, 2017 9:43 AM
    Sunday, February 26, 2017 9:37 AM
  • Hi,

    There is a new line character in the returned string, so it would cause error when saving the PDF since the filename is invalid.

    So please use the code below to remove the unnecessary character.

    strDirectory & "\" & Replace(companyName, Chr(13), "") & "_Page_" & iPDFnum & ".pdf"

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Sunday, February 26, 2017 9:56 AM
    Moderator
  • dear sir

    this is saving files but all the files are saving with only one name PAKISTAN CRICKET BOARD_Page_1(want each file save with their company name) and it should only company name neither that page_1,please look into

    Adeel

    Sunday, February 26, 2017 10:15 AM
  • Hi,

    If so, please use

    strDirectory & "\" & Replace(getFirstCompanyName(iPDFnum), Chr(13), "") & "_Page_" & iPDFnum & ".pdf"

    It could save each file using their company name with page number.

    If you just want the company name without page number, please use

    strDirectory & "\" & Replace(getFirstCompanyName(iPDFnum), Chr(13), "") & ".pdf"

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by Adeeeel Thursday, March 2, 2017 5:27 AM
    Sunday, February 26, 2017 10:28 AM
    Moderator
  • sir this is saving but not accepting special character like \ / ? < > \ : * | " please modify that should accept all characters in company name..? or replace the this type character with dot...

    or some window appear to rename for saving..???there is any possibility..

    Adeel




    • Edited by Adeeeel Monday, February 27, 2017 11:59 AM
    Sunday, February 26, 2017 10:36 AM
  • please modify..??

    Adeel

    Wednesday, March 1, 2017 4:51 AM
  • Hello,

    Please check the code below. It uses regex to replace \ / ? < > \ : * | " into "."

    For i = ipgStart To ipgEnd Dim CName As String
    Dim reg As Object

    CName = Replace(getFirstCompanyName(iPDFnum), Chr(13), "")
    Set reg = CreateObject("VBScript.RegExp")
    reg.IgnoreCase = True
    reg.Global = True
    reg.Pattern = "[><\\\/\*\?:|""]"
    CName = reg.Replace(CName, ".") ActiveDocument.ExportAsFixedFormat OutputFileName:= _ strDirectory & "\" & CName & ".pdf", ExportFormat:=wdExportFormatPDF, _ OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _ wdExportFromTo, From:=i, To:=i, Item:=wdExportDocumentContent, _ IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _ wdExportCreateHeadingBookmarks, DocStructureTags:=True, _ BitmapMissingFonts:=False, UseISO19005_1:=False iPDFnum = iPDFnum + 1 Next i

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    Wednesday, March 1, 2017 9:47 AM
    Moderator
  • thanks dear sir

    this is working now as per my need...lot of thanks

    Adeel


    Thursday, March 2, 2017 5:27 AM