VBA - Convert multiple word docs to PDF with names pulling from word table contents

[mwalker]

Greetings! I'm trying to update this macro so the PDF names pull from the tables within each word doc. I keep getting various errors, including 'object not defined.' I'm relatively new to VBA and am unsure what next steps to take to get this macro working.

Here's the range of text I want to pull from for the PDF file names:
Dim StrFilename AsString
Dim StrNm AsString
Dim StrCat AsString

StrNm = Split(ActiveDocument.Tables(1).Cell(5,1).Range.Text, vbCr)(0)
StrCat = Split(ActiveDocument.Tables(1).Cell(2,1).Range.Text, vbCr)(0)
StrFilename = StrCat &"_"& StrNm &".pdf"


I've been trying to insert the naming rules into this multiple doc --> pdf macro that's working fine as is:

Sub ConvertDocmInDirToPDF()

Dim filePath AsString
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect =False
.Show
OnErrorResumeNext
filePath =.SelectedItems(1)
EndWith

If filePath =""ThenExitSub
If Right(filePath,1)<>""Then filePath = filePath &""

Application.ScreenUpdating =False

Dim currFile AsString
currFile = Dir(filePath &"*.docm")

DoWhile currFile <>""

Documents.Open (filePath & currFile)
Documents(currFile).ExportAsFixedFormat _
OutputFileName:=filePath & Left(currFile, Len(currFile)- Len(".docm"))&".pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
From:=1,To:=1, Item:=wdExportDocumentContent, IncludeDocProps:=True, _
KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, _
DocStructureTags:=True, BitmapMissingFonts:=True, UseISO19005_1:=False
Documents(currFile).Close

currFile = Dir()
Loop

Application.ScreenUpdating =True

EndSub

[macropod]

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, StrPDF As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docm", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
With .Tables(1)
StrPDF = "\" & Split(.Cell(2, 1).Range.Text, vbCr)(0) & _
"_" & Split(.Cell(5, 1).Range.Text, vbCr)(0) & ".pdf"
End With
.SaveAs FileName:=strFolder & StrPDF, FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
PS: When posting code, please use the code tags, indicated by the# button on the posting menu. Without them, your code loses much of whateverstructure it had.

[mwalker]

This worked great - thanks for your help, Paul! And good to know - will use the code tags next time.