Option Explicit
Option Compare Text
Option Private Module
Public Sub DrawingFileIconChange(ByVal strPath As String)
' This will save all corel files with a standard file icon
Dim objCorel As CorelDRAW.Application
Dim objDoc As CorelDRAW.Document
Dim SaveOptions As CorelDRAW.StructSaveAsOptions
Dim vFileArray() As String
Dim i As Long
Dim TempString As String
ReDim vFileArray(0)
' Get all files from strPath
Call ReturnAllFilesUsingDir(strPath, vFileArray())
Set objCorel = New CorelDRAW.Application
Set SaveOptions = New CorelDRAW.StructSaveAsOptions
With SaveOptions
.EmbedVBAProject = False
.Filter = cdrCDR
.IncludeCMXData = False
.Range = cdrAllPages
.EmbedICCProfile = False
.ThumbnailSize = cdrNoThumbnail 'This is for the conversion
.Version = cdrVersion10 'Saved as Version10 for my work's sake
End With
If Not IsError(vFileArray(0)) Then
For i = LBound(vFileArray()) To UBound(vFileArray())
If Right(vFileArray(i), 3) = "cdr" Then
Set objDoc = objCorel.OpenDocument(vFileArray(i))
' SaveAs with no thumbnail (also Version10)
objDoc.SaveAs vFileArray(i), SaveOptions
objDoc.Close
End If
Next
objCorel.Quit
End If
End Sub
Function ReturnAllFilesUsingDir(ByVal vPath As String, ByRef vsArray() As String) As Boolean
' Function thanks to Mvidas from [URL unfurl="true"]www.VBAExpress.com[/URL]
Dim tempStr As String, vDirs() As String, Cnt As Long, dirCnt As Long
Dim PctDone As Long
'Set caption for progress bar
frmProgress.lblDescription = "Searching for Files..."
frmProgress.Repaint
If Len(vsArray(0)) = 0 Then
Cnt = 0
Else
Cnt = UBound(vsArray) + 1
End If
If Right(vPath, 1) <> "\" Then vPath = vPath & "\"
On Error GoTo BadDir
tempStr = Dir(vPath, 31)
Do Until Len(tempStr) = 0
If Asc(tempStr) <> 46 Then
If GetAttr(vPath & tempStr) And vbDirectory Then
ReDim Preserve vDirs(dirCnt)
vDirs(dirCnt) = tempStr
dirCnt = dirCnt + 1
End If
BadDirGo:
End If
tempStr = Dir
SkipDir:
Loop
On Error GoTo BadFile
tempStr = Dir(vPath, 15)
Do Until Len(tempStr) = 0
ReDim Preserve vsArray(Cnt)
vsArray(Cnt) = vPath & tempStr
Cnt = Cnt + 1
tempStr = Dir
Loop
Debug.Print Cnt
BadFileGo:
On Error GoTo 0
If dirCnt > 0 Then
For dirCnt = 0 To UBound(vDirs)
If Len(Dir(vPath & vDirs(dirCnt))) = 0 Then
ReturnAllFilesUsingDir vPath & vDirs(dirCnt), vsArray
End If
Next
End If
Exit Function
BadDir:
If tempStr = "pagefile.sys" Or tempStr = "???" Then
' Debug.Print "DIR: Skipping: " & vPath & tempStr
Resume BadDirGo
ElseIf Err.Number = 52 Then 'or err.number=5 then
' Debug.Print "No read rights: " & vPath & tempStr
Resume SkipDir
End If
Debug.Print "Error with DIR (BadDir): " & Err.Number & " - " & Err.Description
Debug.Print " vPath: " & vPath
Debug.Print " tempStr: " & tempStr
Exit Function
BadFile:
If Err.Number = 52 Then 'or err.number=5 then
' Debug.Print "No read rights: " & vPath & tempStr
Else
Debug.Print "Error with DIR (BadFile): " & Err.Number & " - " & Err.Description
Debug.Print " vPath: " & vPath
Debug.Print " tempStr: " & tempStr
End If
Resume BadFileGo
End Function
)