Hi, this is what i need to do:
1. Choose a folder from the Hard Drive.
2. Inside the choosen folder, i have some rtf files.
3. Loop between those files to open them and then convert them to pdf (using the included plugin on word 2007).
4. Close the files (if the conversion can be done without even open the documents would be great, there are lots of documents).
I know it should be a simple task for most, but i'm more than new to this world. Thanks in advance to everyone.
I've managed to create the following macro, but it just open the document and does nothing afterwards or word just generates an error and closes (most of the time):
Option Explicit
Sub SavePDF()
'
' SavePDF Macro
' Save documents in PDF format
'
Dim txtFolder As String, a, f
Dim strNombreArchivo As String
'Get an existing txt folder name
txtFolder = GetFolder
If txtFolder = vbNullString Then Exit Sub
a = GetFileList(txtFolder & "*.rtf")
If Not IsArray(a) Then
MsgBox "No rtf files found on: " & txtFolder, vbCritical, _
"Macro Ending"
Exit Sub
End If
'Iterate the txt files, open, SaveAs PDF
Application.DisplayAlerts = False
For Each f In a
Documents.Open FileName:=f, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto, XMLTransform:=""
'strNombreArchivo = ActiveDocument.Name
'ChangeFileOpenDirectory "C:\Macro\"
ActiveDocument.ExportAsFixedFormat OutputFileName:=strNombreArchivo, _
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
'Workbooks.Open f
'Edit
'ActiveWorkbook.SaveAs txtFolder & Left(f, Len(f) - 3) & "xls",
'FileFormat:=xlNormal, ConflictResolution:=xlLocalSessionChanges
'ActiveWorkbook.Close False
Next f
Application.DisplayAlerts = True
End Sub
Function GetFolder(Optional sTitle As String = "Select Folder", _
Optional sInitialFilename As String)
Dim myFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
If sInitialFilename = "" Then sInitialFilename = "C:\"
If Right(sInitialFilename, 1) <> "\" Then
sInitialFilename = sInitialFilename & "\"
End If
.InitialFileName = sInitialFilename
.Title = "Greetings"
If .Show = -1 Then
sInitialFilename = .SelectedItems(1)
End If
If Right(sInitialFilename, 1) <> "\" Then
GetFolder = sInitialFilename & "\"
End If
End With
End Function
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
Bookmarks