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