Код:
Private Declare PtrSafe Sub Sleep Lib "kernel32" ( _
ByVal dwMilliseconds As LongLong)
Sub CRD2PDF()
On Error Resume Next
PanoseMatching = cdrPanosePrompt
Dim folder$, coll As Collection
folder$ = "C:\CRD2PDF"
If Dir(folder$, vbDirectory) = "" Then
MsgBox "Folder «" & folder$ & "»", vbCritical, " not present"
Exit Sub ' Exit, if the folder is not found
End If
Do
' Yield to other programs (better than using DoEvents which eats up all the CPU cycles)
DoEvents
Set coll = FilenamesCollection(folder$, "*.cdr") ' get a list of *.cdr files in the folder
' If coll.Count = 0 Then
' MsgBox "In the folder «" & Split(folder$, "\")(UBound(Split(folder$, "\")) - 1) & "» no appropriate files!", _
' vbCritical, "Files for processing not found"
' Exit Sub ' Exit if no files
' End If
' Iterate through all the files
For Each file In coll
PanoseMatching = cdrPanosePermanent 'Skip panose dialog
Set ToPdf = OpenDocument(file) ' Open file from collection
With ToPdf.PDFSettings 'Publish to PDF settings
.PublishRange = 0 ' WholeDocument
.PageRange = ""
.Author = "Published from CorelDraw"
.Subject = ""
.Keywords = "CorelDraw"
.BitmapCompression = 1 ' LZW
.JPEGQualityFactor = 10
.TextAsCurves = True
.EmbedFonts = True
.EmbedBaseFonts = True
.TrueTypeToType1 = True
.SubsetFonts = True
.SubsetPct = 80
.CompressText = True
.Encoding = 1 ' Binary
.DownsampleColor = False
.DownsampleGray = False
.DownsampleMono = False
.ColorResolution = 200
.MonoResolution = 600
.GrayResolution = 200
.Hyperlinks = True
.Bookmarks = True
.Thumbnails = False
.Startup = 0 ' PageOnly
.ComplexFillsAsBitmaps = False
.Overprints = True
.Halftones = False
.MaintainOPILinks = False
.FountainSteps = 256
.EPSAs = 0 ' Postscript
.pdfVersion = 0 ' Version12
.IncludeBleed = False
.Bleed = 31750
.Linearize = False
.CropMarks = False
.RegistrationMarks = False
.DensitometerScales = False
.FileInformation = False
.ColorMode = 3 ' Native
.UseColorProfile = False
.ColorProfile = 1 ' SeparationProfile
.EmbedFilename = ""
.EmbedFile = False
.JP2QualityFactor = 10
.TextExportMode = 0 ' TextAsUnicode
.PrintPermissions = 0 ' PrintPermissionNone
.EditPermissions = 0 ' CEditPermissionNone
.ContentCopyingAllowed = False
.OpenPassword = ""
.PermissionPassword = ""
.EncryptType = 0 ' EncryptTypeNone
.OutputSpotColorsAs = 0 ' SpotAsSpot
.OverprintBlackLimit = 95
.ProtectedTextAsCurves = True
End With
For Each p In ActiveDocument.Pages 'Search first text objects on document pages
p.Activate
If ActivePage.Shapes.FindShapes(Type:=cdrTextShape).Count > 0 Then ' Text object found in document
Exit For ' Break
End If
Next p
If ActivePage.Shapes.FindShapes(Type:=cdrTextShape).Count > 0 Then
' Text object found in document
Open Mid(ToPdf.FullFileName, 1, Len(ToPdf.FullFileName) - 3) & "txt" For Output As #1 'Open txt file
Print #1, "Some text objects NOT in curves" 'Write in text file warning
Close #1
Else
' Text object NOT found in document, publish to PDF
ToPdf.PublishToPDF Mid(ToPdf.FullFileName, 1, Len(ToPdf.FullFileName) - 3) & "pdf"
End If
ToPdf.Close 'Close CRD file
Kill file 'Delete CDR file
Next
Call DelOldFiles(3, "*.pdf") ' Delete PDF older than ... days
Call DelOldFiles(3, "*.txt") ' Delete TXT older than ... days
Sleep 5 * 1000 'Pause X * 1000 sec
Loop
End Sub
Sub DelOldFiles(Days As Double, Optional ByVal Mask As String = "")
On Error Resume Next
Dim folder$, coll As Collection
folder$ = "C:\CRD2PDF"
If Dir(folder$, vbDirectory) = "" Then
MsgBox "Folder «" & folder$ & "»", vbCritical, " not present"
Exit Sub ' exit, if the folder is not found
End If
Set coll = FilenamesCollection(folder$, Mask) ' get a list of *.pdf files in the folder
For Each file In coll ' Loop through the files
If FileDateTime(file) < Now - Days Then Kill file ' Delete the file if it is older than ... days
Next
End Sub
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
Optional ByVal SearchDeep As Long = 999) As Collection
' Receives as a parameter the path to the folder FolderPath, the name of the desired mask files Mask
' (to be selected, only files with a mask / expansion) and SearchDeep search depth in the folder
' (if SearchDeep = 1, the sub-folders are not visible).
' Returns a collection that contains the full path of files found (Used recursive call GetAllFileNamesUsingFSO procedure)
Set FilenamesCollection = New Collection ' create an empty collection
Set FSO = CreateObject("Scripting.FileSystemObject") ' create an instance of FileSystemObject
GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' Search
Set FSO = Nothing: Application.StatusBar = False ' Clear variables
End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
If Not curfold Is Nothing Then ' If able to access the folder
For Each fil In curfold.Files ' Go through all the files in a FolderPath
If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
Next
SearchDeep = SearchDeep - 1 ' Reduce the depth of search in subfolders
If SearchDeep Then ' If it is necessary to look deeper
For Each sfol In curfold.SubFolders ' Iterate through all subfolders in the folder FolderPath
GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
Next
End If
Set fil = Nothing: Set curfold = Nothing ' Clear variables
End If
End Function