Would it possibile to add some code line to [thees] 1 in order to export pdf from word having also bookmarks? (without opening)
'Convert .doc or .docx to .pdf files via Send To menu
Set fso = CreateObject("Scripting.FileSystemObject")
For i= 0 To WScript.Arguments.Count -1
docPath = WScript.Arguments(i)
docPath = fso.GetAbsolutePathName(docPath)
If LCase(Right(docPath, 4)) = ".doc" Or LCase(Right(docPath, 5)) = ".docx" Then
Set objWord = CreateObject("Word.Application")
pdfPath = fso.GetParentFolderName(docPath) & "\" & _
fso.GetBaseName(docpath) & ".pdf"
objWord.Visible = False
Set objDoc = objWord.documents.open(docPath)
objDoc.saveas pdfPath, 17
objDoc.Close
objWord.Quit
End If
Next
Related
I have a lot of Word documents that I need to save as a PDF so I've found a script that can save the documents as a PDF. However, how do I ensure that it's saved with "No Markup"?
This is the script for reference (taken from https://www.winhelponline.com/blog/how-to-batch-convert-word-documents-into-pdf-files/):
Set fso = CreateObject("Scripting.FileSystemObject")
For i= 0 To WScript.Arguments.Count -1
docPath = WScript.Arguments(i)
docPath = fso.GetAbsolutePathName(docPath)
If LCase(Right(docPath, 4)) = ".doc" Or LCase(Right(docPath, 5)) = ".docx" Then
Set objWord = CreateObject("Word.Application")
pdfPath = fso.GetParentFolderName(docPath) & "\" & _
fso.GetBaseName(docpath) & ".pdf"
objWord.Visible = False
Set objDoc = objWord.documents.open(docPath)
objDoc.saveas pdfPath, 17
objDoc.Close
objWord.Quit
End If
Next
i currently have 6 mail merge templates that i execute via the following vbs.
this opens each file in the root folder and runs the mailmerge,
VBS
Set fs = CreateObject("Scripting.FileSystemObject")
Set rootFolder = fs.GetFolder(fs.GetParentFolderName(wscript.ScriptFullName))
Set oWord = Createobject("Word.Application")
oWord.Visible = False
For Each file in rootFolder.Files
If LCase(fs.GetExtensionName(file.Name)) = "docx" Then
Set oDocument = oWord.Documents.Open(file.path)
oWord.Run "regular_mail"
oDocument.Close(False)
Set oDocument = Nothing
End If
Next
oWord.Quit
set oWord = nothing
the vba inside word, does the mailmerge puts it in the designated folder, what i get is an error when the datasource for that file has no data. since StrName = .DataFields("pk") wont have any values.
Where im stuck is how to go around that error, or check whether the data source is blank then move on to the next template.
each template should save to one file so my mailroom can print.
VBA in word:
Sub regular_mail()
Dim sDate As String, StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long, fso As Object, StrMonthPath As String, StrDayPath As String, StrFileName As String
sDate = Format(Now(), "mmddyy")
Const StrFolderName As String = "C:\Test\Files\"
Set fso = CreateObject("Scripting.FileSystemObject")
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
StrName = .DataFields("pk")
StrMonthPath = .DataFields("month_path")
StrDayPath = .DataFields("day_path")
StrSendDate = .DataFields("send_date")
StrFileName = sDate & "_" & fso.GetBaseName(ActiveDocument.Name)
End With
.Execute Pause:=False
'Creates directory if it doesnt exist
If Not fso.FolderExists(StrFolderName & StrMonthPath) Then
fso.CreateFolder (StrFolderName & StrMonthPath)
End If
If Not fso.FolderExists(StrFolderName & StrMonthPath & StrDayPath) Then
fso.CreateFolder (StrFolderName & StrMonthPath & StrDayPath)
End If
If Not fso.FolderExists(StrFolderName & StrMonthPath & StrDayPath & "letters\") Then
fso.CreateFolder (StrFolderName & StrMonthPath & StrDayPath & "letters\")
End If
End With
ActiveDocument.SaveAs2 FileName:=StrFolderName & StrMonthPath & StrDayPath & "letters\" & StrFileName, FileFormat:=16, AddToRecentFiles:=False
ActiveWindow.Close
End Sub
any and all help is appreciated, thank you in advance.
Without being able to test it myself right now, you could use both or one of these approaches:
You could check it DataSource is nothing (or if is not Nothing, as you need):
If .DataSource Is Nothing Then ...
You could check if there are records in the Datasource:
If .DataSource.RecordCount = 0 Then
I have an Outlook macro that saves an email as a PDF. It is passed the name of the file (EmailName) from the subject\input box and the folder (strFolder) to save to.
I am using PDFTK to create the PDF.
I show the SaveAs dialog box to save.
If dlgSaveAs.Show = -1 Then
strCurrentFile = dlgSaveAs.SelectedItems(1)
Is there a way of saving the email as PDF without showing the SaveAs dialog box to confirm the file name\folder?
----------------------------------------------------------------------------
Public Function EVAL_SaveAsPDFfile(EmailName As String, strFolder As String) As String
'====================================================
' Description: Outlook macro to save a selected item in the pdf-format
' Requires Word 2007 SP2 or Word 2010
' Requires a reference to "Microsoft Word Object Library"
' (version is 12.0 or 14.0)
' In VBA Editor; Tools-> References...
'====================================================
' also microsoft shell controls and automation
'=============================================
' set share location
'=============================================
' On Error GoTo ErrorHandling
'Root folder
Dim strTempFileName As String
strTempFileName = "\\asfs1\cons\clients"
If (Right(strFolder, 1) = "\") Then
Else
strFolder = strFolder + "\"
End If
'PDFTK
Dim program As String
program = strTempFileName & "\crm\pdftk.exe"
Dim directoremail As String
directoremail = "email#address.co.uk"
FUNC_SYSTEM_FolderExistsCreate (strFolder)
FUNC_SYSTEM_FolderExistsCreate (strTempFileName)
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(strTempFileName) Then
'Get all selected items
Dim MyOlNamespace As Outlook.NameSpace
Set MyOlNamespace = Application.GetNamespace("MAPI")
Set MyOlSelection = Application.ActiveExplorer.Selection
'Make sure at least one item is selected
If MyOlSelection.Count <> 1 Then
Response = MsgBox("Please select a single item", vbExclamation, "Save as PDF")
Exit Function
End If
'Retrieve the selected item
Set MySelectedItem = MyOlSelection.Item(1)
'Get the user's TempFolder to store the item in
Dim tmpString As String
Dim tmpFileName As String, newFileName As String
tmpString = strTempFileName & "\crm\temp\" & Format(Now, "yyyyMMddHHmmss")
'construct the filename for the temp mht-file
tmpFileName = tmpString & ".mht"
'newFileName = tmpString & ".pdf"
newFileName = EmailName & ".pdf"
'Save the mht-file
MySelectedItem.SaveAs tmpFileName, olMHTML
'Create a Word object
Dim wrdApp As Word.Application
Dim wrdDoc As Word.document
Set wrdApp = CreateObject("Word.Application")
'Open the mht-file in Word without Word visible
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False)
'Define the SafeAs dialog
Dim dlgSaveAs As FileDialog
Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)
'Determine the FilterIndex for saving as a pdf-file
'Get all the filters
Dim fdfs As FileDialogFilters
Dim fdf As FileDialogFilter
Set fdfs = dlgSaveAs.Filters
'Loop through the Filters and exit when "pdf" is found
Dim i As Integer
i = 0
For Each fdf In fdfs
i = i + 1
If InStr(1, fdf.Extensions, "pdf", vbTextCompare) > 0 Then
Exit For
End If
Next fdf
'Set the FilterIndex to pdf-files
dlgSaveAs.FilterIndex = i
'Get location of My Documents folder
Dim WshShell As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
SpecialPath = WshShell.SpecialFolders(16)
'Construct a safe file name from the message subject
Dim msgFileName As String
msgFileName = MySelectedItem.subject
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[\\/:*?""<>|]"
msgFileName = Trim(oRegEx.Replace(msgFileName, ""))
'Set the initial location and file name for SaveAs dialog
'=============================================
' set default location
'=============================================
Dim strCurrentFile As String
If (TypeOf MyOlSelection.Item(1) Is Outlook.mailitem) Then
strCurrentFile = GetClientFolder(MyOlSelection.Item(1))
End If
If strCurrentFile = vbNullString Then
dlgSaveAs.InitialFileName = strFolder
Else
If FileFolderExists(strCurrentFile & "\") Then
dlgSaveAs.InitialFileName = strCurrentFile & "\"
Else
dlgSaveAs.InitialFileName = strFolder
End If
End If
dlgSaveAs.Execute
Set objFSO = CreateObject("Scripting.FileSystemObject")
' minimize outlook to show save as dialog
Set OutlookObj = GetObject(, "Outlook.Application")
OutlookObj.ActiveExplorer.WindowState = olMinimized
Dim objShell As Shell
Set objShell = New Shell
'' objShell.MinimizeAll
'Show the SaveAs dialog and save the message as pdf
newFileName = Replace(newFileName, ":", " -", Start:=1)
dlgSaveAs.InitialFileName = strFolder + newFileName
dlgSaveAs.Execute
If dlgSaveAs.Show = -1 Then
strCurrentFile = dlgSaveAs.SelectedItems(1)
'Verify if pdf is selected
If Right(strCurrentFile, 4) <> ".pdf" Then
Response = MsgBox("Sorry, only saving in the pdf-format is supported." & vbNewLine & vbNewLine & "Save as PDF instead?", vbInformation + vbOKCancel)
If Response = vbCancel Then
' wrdDoc.Close
' wrdApp.Quit
Exit Function
ElseIf Response = vbOK Then
intPos = InStrRev(strCurrentFile, ".")
If intPos > 0 Then
strCurrentFile = Left(strCurrentFile, intPos - 1)
End If
strCurrentFile = strCurrentFile & ".pdf"
End If
End If
'Save as pdf
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:=newFileName, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:=True, UseISO19005_1:=False
EVAL_SaveAsPDFfile = strCurrentFile
' now append the temp file with the chosen one
'=============================================
' set pdftk location
'=============================================
Dim tempPDF
tempPDF = tmpString & " temp.pdf"
' if existing file, append to old
If objFSO.FileExists(strCurrentFile) Then
Dim command As String
command = Chr(34) & program & Chr(34) & " " & Chr(34) & newFileName & Chr(34) & " " & Chr(34) & strCurrentFile & Chr(34) & " cat output " & Chr(34) & tempPDF & Chr(34)
Dim oShell
Set oShell = CreateObject("WScript.Shell")
fdsk = oShell.Run(command, 1, True)
Set oShell = Nothing
' MsgBox ("Temp: " & tempPDF + ", Current: " & strCurrentFile)
objFSO.CopyFile tempPDF, strCurrentFile, True
Else
' create file to be overwriten
Dim fsonewpdf As Object
Set fsonewpdf = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fsonewpdf.CreateTextFile(strCurrentFile)
oFile.WriteLine "test"
oFile.Close
Set fsonewpdf = Nothing
Set oFile = Nothing
objFSO.CopyFile newFileName, strCurrentFile, True
End If
'copy new file to saveas file
'delete temp files
If objFSO.FileExists(tempPDF) Then
objFSO.DeleteFile tempPDF
End If
If objFSO.FileExists(newFileName) Then
objFSO.DeleteFile newFileName
End If
'close the document and Word
wrdDoc.Close
'wrdApp.Quit
If objFSO.FileExists(tmpFileName) Then
objFSO.DeleteFile tmpFileName
End If
Else
' close the document and Word
wrdDoc.Close
'wrdApp.Quit
End If
If objFSO.FileExists(tmpFileName) Then
objFSO.DeleteFile tmpFileName
End If
' maximize outlook now that we have finished
''OutlookObj.ActiveExplorer.WindowState = olMaximized
'objShell.UndoMinimizeALL
Set objShell = Nothing
Set dlgSaveAs = Nothing
'Cleanup
Set MyOlNamespace = Nothing
Set MyOlSelection = Nothing
Set MySelectedItem = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set oRegEx = Nothing
End If
'ErrorHandling:
' MsgBox "The Email failed to save, please delete the Evaluation record and try again or manually save the email as a PDF and add it.", vbOKOnly, "Error Saving Email"
' EVAL_SaveAsPDFfile = ""
End Function
I would like to open a Word doc, paste data from my Excel file and then save that Word document.
Opening Word and pasting the data works fine, but it doesn't save the file due to a problem with the line "ChDir "C:\My Documents\".
What am I missing here?
Sub macro()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
WordApp.Activate
Set WordDoc = WordApp.Documents.Add
Range("A1:C33").Copy
WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _Placement:=wdInLine, DisplayAsIcon:=False
WordDoc.PageSetup.LeftMargin = CentimetersToPoints(1.5)
WordDoc.PageSetup.TopMargin = CentimetersToPoints(1.4)
WordDoc.PageSetup.BottomMargin = CentimetersToPoints(1.5)
ChDir "C:\My Documents\Test"
ActiveDocument.SaveAs "Archief" & Format(Now, "yyyymmdd") & ".docx"
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
It would be easier to create a variable to include both the path and the name of the file, like this :
Dim FileFullName As String
FileFullName = Environ("userprofile") & "\My Documents\Test" & "\" & "Archief" & Format(Now, "yyyymmdd") & ".docx"
ActiveDocument.SaveAs FileFullName
Try this:
Dim FileName2 As String
Set appWrd = CreateObject("Word.Application")
appWrd.DisplayAlerts = False
FileName2 = Document.Path & "\" & ".docx"
appWrd.ActiveDocument.SaveAs FileName:=FileName2
[Using MS Word 2010]
I have a macro that converts a Word document from docx format to txt format. However there are some documents that stop during conversion with the following notification: "The document may contain text content that will be lost upon conversion to the chosen encoding. To preserve this content , click No to exit this dialog box,and then choose another encoding that supports the languages in this document.
Do you want to continue saving the document? Yes/No"
Of course I want to continue to save the document as txt so I have to click the Yes button. I am converting hundreds of documents (docx) to text and want the macro to intercept this message and tell Word 'Yes" without my intervention. Can anyone tell me the VBA code needed to accomplish this and where in my macro does it need to go? I am a complete novice to VBA. I found the following VBA code on the Internet and it works fine except for what I just indicated about the Word message. Here is the code:
Sub ChangDocsToTxtOrRTForHTML()
'with export to PDF in word 2007
Dim fs As Object
Dim oFolder As Object
Dim tFolder As Object
Dim oFile As Object
Dim strDocName As String
Dim intPos As Integer
Dim locFolder As String
Dim fileType As String
On Error Resume Next
locFolder = InputBox("Enter the folder path do DOCs", "File Conversion", "C:\myDocs")
Select Case Application.Version
Case Is < 12
Do
fileType = UCase(InputBox("Change DOC to TXT, RTF, HTML", "File Conversion", "TXT"))
Loop Until (fileType = "TXT" Or fileType = "RTF" Or fileType = "HTML")
Case Is >= 12
Do
fileType = UCase(InputBox("Change DOC to TXT, RTF, HTML, or PDF(2007+ only)", "File Conversion", "TXT"))
Loop Until (fileType = "TXT" Or fileType = "RTF" Or fileType = "HTML" Or fileType = "PDF")
End Select
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
Set oFolder = fs.GetFolder(locFolder)
Set tFolder = fs.CreateFolder(locFolder & "Converted")
Set tFolder = fs.GetFolder(locFolder & "Converted")
For Each oFile In oFolder.Files
Dim d As Document
Set d = Application.Documents.Open(oFile.Path)
strDocName = ActiveDocument.Name
intPos = InStrRev(strDocName, ".")
strDocName = Left(strDocName, intPos - 1)
ChangeFileOpenDirectory tFolder
Select Case fileType
Case Is = "TXT"
strDocName = strDocName & ".txt"
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatText
Case Is = "RTF"
strDocName = strDocName & ".rtf"
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatRTF
Case Is = "HTML"
strDocName = strDocName & ".html"
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatHTML
Case Is = "PDF"
strDocName = strDocName & ".pdf"
'*** Word 2007 users - remove the apostrophe at the start of the next line ***
'ActiveDocument.ExportAsFixedFormat OutputFileName:=strDocName, ExportFormat:=wdExportFormatPDF
End Select
d.Close
ChangeFileOpenDirectory oFolder
Next oFile
Application.ScreenUpdating = True
End Sub
Sub ConvertFiles()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.txt", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, _
Format:=wdOpenFormatEncodedText, Encoding:=msoEncodingUTF8, _
AddToRecentFiles:=False, Visible:=False)
wdDoc.SaveAs2 FileName:=strFolder & "\" & Replace(strFile, ".txt", ".docx"), _
Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
wdDoc.Close SaveChanges:=False
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
Thank you for your help.
ntman2
For text files, Word is able to use different encoding schemes for saved-as files that can avoid generating this warnings. Try:
ActiveDocument.SaveAs _
FileName:=strDocName, _
Fileformat:=wdFormatText, _
Encoding:=msoEncodingUnicodeLittleEndian
instead of:
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatText