Splitting Out PDFs

4mysanity · #1 11-29-2012, 10:31 AM

test.docx

Hello,

In my word document, I have paragraphs, each paragraph has a number, ie: the first paragraph is labelled 001, the second paragraph is labelled 002 and so on.

What I want to do is have my VBA code in word match those paragraph numbers to an image with the same number, then have word automatically save the image & paragraph as one .pdf. So for example, the code would match paragraph 001 with image 001 and save it as 001.pdf

Here is an example of what I got so far, (see attachment). The path to the images is K:\test\images\ the images are just saved on my hard drive they aren't in the word document

Im just a little unsure as to where to go from here, I know how to get Word to save as a .pdf but I dont know how to get it to distinguish between the different paragraphs. Any help would be great!

Thanks!

macropod · #2 11-29-2012, 04:18 PM

From what you've described, the code to insert the images would be something like:

Code:

Sub InsertPicsToPDF()
Application.ScreenUpdating = False
Dim Para As Paragraph, Str As String, i As Long, Rng As Range
With ActiveDocument
  For Each Para In .Paragraphs
    Str = Trim(Para.Range.Words.First)
    If Str Like "###" Then
      Para.Range.InsertBefore Chr(12)
      Para.Range.InsertAfter vbCr
      .InlineShapes.AddPicture FileName:="K:\test\images\" & Str & ".jpg", _
        LinkToFile:=False, SaveWithDocument:=True, Range:=Para.Range.Characters.Last
    End If
  Next
  .Characters.First.Delete
  For i = 1 To .ComputeStatistics(wdStatisticPages)
    Set Rng = ActiveDocument.GoTo(What:=wdGoToPage, Name:=i)
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
    If Rng.Characters.Last = Chr(12) Then Rng.MoveEnd wdCharacter, -1
    Str = Trim(Rng.Words.First)
    Rng.Copy
    Documents.Add
    With ActiveDocument
      .Range.Paste
      .SaveAs2 FileName:="K:\test\images\" & Str & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  Next
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

To generate the PDFs you would need to have each record on its own page, which the macro does.

4mysanity · #3 11-30-2012, 10:24 AM

Hey there,

Thanks for the response, Ive got some good news and bad news. The script saves a PDF

AND it saves the pdf with the correct text and image. The only issue is, I want to add a space between the picture and the text...For example:

Right now the text is on the same line as the image, like this:

<Image><text>

I would like it to be displayed like this:

<Image>(centered on the page)
vbNewLine
<Text About The Image Here> (aligned left)

I tried using

Code:

 Para.Range.InsertAfter vbNewLine

- but it didn't seem to do anything.

Thanks!

Here is the full code:

Code:

Sub Splitter()
Selection.EndKey Unit:=wdStory
numlets = Selection.Information(wdActiveEndSectionNumber)
If numlets > 1 Then numlets = numlets - 1
Selection.HomeKey Unit:=wdStory
BaseName = "k:\test\images"
For Counter = 1 To numlets
DocName = BaseName & Right("0" & LTrim(Str(Counter)), 10)
ActiveDocument.Sections.First.Range.Cut
Documents.Add
Selection.Paste
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveDocument.SaveAs FileName:=DocName, FileFormat:=wdFormatPDF
ActiveWindow.Close
Next Counter
End Sub
Sub InsertPicsToPDF()
Application.ScreenUpdating = False
Dim Para As Paragraph, Str As String, i As Long, Rng As Range
With ActiveDocument
  For Each Para In .Paragraphs
    Str = Trim(Para.Range.Words.First)
    If Str Like "###" Then
      Para.Range.InsertBefore Chr(12)
      Para.Range.InsertAfter vbCr
      .InlineShapes.AddPicture FileName:="K:\test\images\" & Str & ".jpg", _
        LinkToFile:=False, SaveWithDocument:=True, Range:=Para.Range.Characters.Last
    End If
  Next
  .Characters.First.Delete
  For i = 1 To .ComputeStatistics(wdStatisticPages)
    Set Rng = ActiveDocument.GoTo(What:=wdGoToPage, Name:=i)
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
    If Rng.Characters.Last = Chr(12) Then Rng.MoveEnd wdCharacter, -1
    Str = Trim(Rng.Words.First)
    Rng.Copy
    Documents.Add
    With ActiveDocument
      .Range.Paste
      .SaveAs2 FileName:="K:\test\images" & Str & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  Next
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

macropod · #4 11-30-2012, 07:17 PM

Try:

Code:

Sub InsertPicsToPDF()
Application.ScreenUpdating = False
Dim Para As Paragraph, Str As String, i As Long, Rng As Range, sPath As String
sPath = "K:\test\images\"
With ActiveDocument
  For Each Para In .Paragraphs
    Str = Trim(Para.Range.Words.First)
    If Str Like "###" Then
    Set Rng = Para.Range
      With Rng
        .InsertBefore Chr(12)
        .Collapse wdCollapseEnd
        .InsertAfter vbCr
        .Collapse wdCollapseStart
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
      End With
      .InlineShapes.AddPicture FileName:=sPath & Str & ".jpg", _
        LinkToFile:=False, SaveWithDocument:=True, Range:=Rng
    End If
  Next
  .Characters.First.Delete
  For i = 1 To .ComputeStatistics(wdStatisticPages)
    Set Rng = ActiveDocument.GoTo(What:=wdGoToPage, Name:=i)
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
    If Rng.Characters.Last = Chr(12) Then Rng.MoveEnd wdCharacter, -1
    Str = Trim(Rng.Words.First)
    Rng.Copy
    Documents.Add
    With ActiveDocument
      .Range.Paste
      .SaveAs2 FileName:=sPath & Str & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  Next
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

As I don't know what your 'Splitter' sub is about, I haven't really given it much consideration, though I note your 'SaveAs' won't work - you need 'SaveAs2'.

4mysanity · #5 12-03-2012, 07:46 AM

Hey Pal,

Sorry for the late response. Thanks for the correction in code. Yeah the beginning part isn't necessary to worry about.

Your code worked! The only thing, is it inserted the picture the way I described, except it inserted after the first sentence of the paragraph. (See attached photo for an example)

citgo.pdf

The image appears below the guys name "001 Joe Smith Process Engineer", it should be above the guy's name. Any idea why that might be?

Thanks again for your help!

macropod · #6 12-03-2012, 03:27 PM

Quote:

Originally Posted by 4mysanity

The image appears below the guys name "001 Joe Smith Process Engineer", it should be above the guy's name. Any idea why that might be?

Because that's how I coded it. It wasn't clear from your previous posts that you wanted the image above the name. To put it above the name, change the With Rng ... End With block to:

Code:

      With Rng
        .Collapse wdCollapseStart
        .InsertBefore Chr(12) & vbCr
        .MoveStart wdCharacter, 1
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
      End With

4mysanity · #7 12-03-2012, 03:38 PM

Thanks Pal!

Just a quick question, seems to work, sort of, I executed the Macro and got an error on this line

Code:

.SaveAs2 FileName:=sPath & Str & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False

But then I reset the project, executed the Macro and it worked perfectly. Then I tried testing it one more time, then got an error on this line (which is 12 lines up from the end of the End Sub command:

Code:

Rng.Copy

any idea why that might be? I thought it had something to do with the desination folder I was saving in, but that wasn't it.

4mysanity · #8 12-03-2012, 03:44 PM

Nope you know what, its definitely not the Rng.Copy aspect, its the

Code:

.SaveAs2 FileName:=sPath & Str & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False

Closed out of the project, re-opened it, tested it again, and it was that lineVBA editor highlighted.

Sorry for the second post.

macropod · #9 12-03-2012, 03:44 PM

I overlooked a downstream effect. Change:
Str = Trim(Rng.Words.First)
to:
Str = Trim(Rng.Paragraphs(2).Range.Words.First)

4mysanity · #10 12-03-2012, 03:45 PM

Thanks man, let me try that out

4mysanity · #11 12-03-2012, 03:46 PM

"The requested member of the colection oes not exist"

Was the error it gave me.

macropod · #12 12-03-2012, 03:55 PM

The code works fine when I use it. Are you sure you're running it on a fresh document?

PS: Please don't keep quoting entire previous posts in your replies. If there is something that you need to make particular reference to, quote just that part.

4mysanity · #13 12-03-2012, 04:12 PM

Hey bud,

Sorry about all that. It seems to have worked this time. That was weird! Just kinda went all finnickie then started to work, hmm. Welp, thank you very much in any sense.

I shall mark this as solved!

Quote:

Originally Posted by macropod

The code works fine when I use it. Are you sure you're running it on a fresh document?

PS: Please don't keep quoting entire previous posts in your replies. If there is something that you need to make particular reference to, quote just that part.

4mysanity · #14 12-04-2012, 03:59 PM

Hey There

Had to hard this as unsolved due to a delimma I just started encountering. The script was working fine, but just now (literally a few minutes ago) - suddenly when the macro got executed - the script started opening a new word document, then prompting me if I wanted to save that word document

Any idea why that might be, script below, and I also attached a sample.

Thanks
test.docx

Code:

Sub Splitter()
Selection.EndKey Unit:=wdStory
numlets = Selection.Information(wdActiveEndSectionNumber)
If numlets > 1 Then numlets = numlets - 1
Selection.HomeKey Unit:=wdStory
BaseName = "k:\test\images"
For Counter = 1 To numlets
DocName = BaseName & Right("0" & LTrim(Str(Counter)), 10)
ActiveDocument.Sections.First.Range.Cut
Documents.Add
Selection.Paste
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveDocument.SaveAs FileName:=DocName, FileFormat:=wdFormatPDF
ActiveWindow.Close
Next Counter
End Sub
 
Sub InsertPicsToPDF()
Application.ScreenUpdating = False
Dim Para As Paragraph, Str As String, i As Long, Rng As Range, sPath As String
sPath = "K:\test\images\"
With ActiveDocument
  For Each Para In .Paragraphs
    Str = Trim(Para.Range.Words.First)
    If Str Like "###" Then
    Set Rng = Para.Range
      With Rng
        .Collapse wdCollapseStart
        .InsertBefore Chr(12) & vbCr
        .MoveStart wdCharacter, 1
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
      End With
      .InlineShapes.AddPicture FileName:=sPath & Str & ".jpg", _
        LinkToFile:=False, SaveWithDocument:=True, Range:=Rng
    End If
  Next
  .Characters.First.Delete
  For i = 1 To .ComputeStatistics(wdStatisticPages)
    Set Rng = ActiveDocument.GoTo(What:=wdGoToPage, Name:=i)
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
    If Rng.Characters.Last = Chr(12) Then Rng.MoveEnd wdCharacter, -1
    Str = Trim(Rng.Paragraphs(2).Range.Words.First)
    Rng.Copy
    Documents.Add
    With ActiveDocument
      .Range.Paste
      .SaveAs2 FileName:=sPath & Str & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  Next
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

Quote:

Originally Posted by 4mysanity

Hey bud,

Sorry about all that. It seems to have worked this time. That was weird! Just kinda went all finnickie then started to work, hmm. Welp, thank you very much in any sense.

I shall mark this as solved!

macropod · #15 12-04-2012, 04:04 PM

Are you sure you're not trying to save over files you've already created in a previous run of the macro?

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Inserted PDFs become Pixelated in Powerpoint	fongchun	PowerPoint	0	11-26-2012 06:24 PM
My Word 2007 doesnt display PDFs correctly	mattk561	Word	8	10-31-2012 08:04 PM
Embedding PDFs in MS Word 2010	chitownbillj	Word	1	06-30-2012 12:01 AM
Creating High Quality PDFs from Word 2010	BrazzellMarketing	Word	11	01-27-2012 01:06 PM
Converting Powerpoint into Fully Accessable PDFs	KCD123	PowerPoint	4	09-28-2011 10:03 AM