Måske kan dette hjælpe som jeg fandt under
www.planetpdf.comHow to convert a folder full of Excel files to PDF
Option Explicit
' Author : Karl De Abrew
' Company : A Round Table Solution
' Date : 12 February 1999
' URL :
http://www.codecuts.com/ ' Version : 1.0
' Description: This is a simple demonstration of how all Excel
' files in a given folder can be converted to PDFs. The
' Distiller Assistant printer must be configured and operational
' for this to work. No bookmarks or hyperlinks are added - just plain
' old vanilla PDF. You'll also notice that the printername is hardcoded.
' It would be a good idea to have this set as a variable.
' Use this as you see fit.
' *** Don't forget to reference the Excel.8 library in your project
'///////////////////////////////////////////////////
'///////////////////////////////////////////////////
' WIN 32 API function declarations
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
' Win32 Constant Declarations and other constants
Private Const MAX_PATH = 260
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
' Win32 Type Declarations
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
'///////////////////////////////////////////////////
'///////////////////////////////////////////////////
Private m_strError As String
'///////////////////////////////////////////////////
'///////////////////////////////////////////////////
Function GetLastError() As String
GetLastError = m_strError
m_strError = ""
End Function
'///////////////////////////////////////////////////
'///////////////////////////////////////////////////
Function ConvertFile(strSourceFileName As String, strDestinationFileName As String) As String
On Error GoTo ErrorHandler
Dim msExcel As Excel.Application
Set msExcel = GetObject(Class:="Excel.Application.8")
msExcel.Visible = True
msExcel.Workbooks.Open strSourceFileName, UpdateLinks:=False ', ReadOnly:=True
msExcel.ActiveWorkbook.PrintOut ActivePrinter:="Distiller Assistant v3.01"
' Wait for the file to be distilled
While IsFileDistilledYet(msExcel.ActiveWorkbook.Name, strDestinationFileName) <> True
Sleep 1000
Wend
msExcel.ActiveWorkbook.Close False
' Should check and quit excel when done
Set msExcel = Nothing
ConvertFile = True
Exit Function
'////////////////////////////////////////////////////
ErrorHandler:
' Create Excel for the first time if it is not active
If Err.Number = 429 Then
Set msExcel = CreateObject("Excel.Application.8")
Err.Clear ' Clear Err object in case error occurred.
Resume
End If
' All other errors handled here
If IsCriticalError Then
ConvertFile = False
Exit Function
Else
Resume
End If
End Function
'///////////////////////////////////////////////////
'///////////////////////////////////////////////////
Private Function IsCriticalError() As Boolean
Dim strErrorMessage As String
Select Case Err.Number ' Evaluate error number.
Case Else
strErrorMessage = "Please contact info@CodeCuts.com and inform them that" & Chr$(13) & _
"the error message reported by the operating system was " & Chr$(13) & _
Chr$(34) + Trim(Str(Err.Number)) & " " & Err.Description + Chr$(34)
MsgBox strErrorMessage, , "Conversion error" + Str(Err.Number)
IsCriticalError = True
Exit Function
End Select
IsCriticalError = False
End Function
'///////////////////////////////////////////////////
'///////////////////////////////////////////////////
Function IsFileDistilledYet(strFileName As String, strOrigFileName) As Boolean
Dim FindData As WIN32_FIND_DATA
Dim strOutputFileName As String
Dim strDestFileName As String
Dim strFindFileName As String
Dim StrLen As Integer
strOutputFileName = LCase("c:\" + Left(strFileName, Len(strFileName) - 3) + "pdf")
' Check to see that the file has been created
FindFirstFile strOutputFileName, FindData
StrLen = InStr(FindData.cFileName, Chr(0))
strFindFileName = LCase("c:\" + Left(FindData.cFileName, StrLen - 1))
If strOutputFileName = strFindFileName Then
IsFileDistilledYet = True
' Build the destination filename from the orginal source document filename
strDestFileName = Left(strOrigFileName, Len(strOrigFileName) - 3) + "pdf"
' Move the distilled file to it's original location
MoveFile strFindFileName, strDestFileName ' SHOULD CHECK FOR ERRORS HERE
Else
IsFileDistilledYet = False
End If
End Function
'///////////////////////////////////////////////////
'///////////////////////////////////////////////////
Private Sub Command1_Click()
Dim strFileToConvert As String
Dim strDestinationFile As String
Dim strFolder As String
' Set the source folder
strFolder = "c:\temp\"
' Grab the first file to convert
strFileToConvert = Dir(strFolder + "*.xls")
' Loop through all excel files
While strFileToConvert <> ""
' Create the destination filename
strDestinationFile = Left(strFileToConvert, Len(strFileToConvert) - 4)
strDestinationFile = strDestinationFile + ".pdf"
' Attempt to convert the file to PDF
If (ConvertFile(strFolder + strFileToConvert, strFolder + strDestinationFile) = False) Then
' Hmmm, looks like something went wrong - let's prompt the user to see if they wish to quit
If (MsgBox("There has been a problem converting the file " + strFileToConvert, vbYesNo) = vbYes) Then
' Finish up - let's get out of here
Exit Sub
End If
End If
' Grab the next file
strFileToConvert = Dir
Wend
End Sub
