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):
Code: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
There are currently 1 users browsing this thread. (0 members and 1 guests)
Bookmarks