PDA

View Full Version : Solved: xls to xlsm files.



Pinokkio
02-07-2010, 01:26 PM
This macro change xls-files to xlsm-files in one folder:


Dim result As String
Dim objFSO As Object

Sub Start()
result = BrowseForFolder
Select Case result
Case Is = False
result = "an invalid folder!"
Case Else
End Select
TrandformAllXLSFilesToXLSM
End Sub

Public Sub TrandformAllXLSFilesToXLSM()
Dim myPath As String

myPath = result & "\"

Set objFSO = CreateObject("Scripting.FileSystemObject")
ShowSubFolders objFSO.GetFolder(myPath)


WorkFile = Dir(myPath & "*.xls")

Do While WorkFile <> ""
If Right(WorkFile, 4) <> "xlsm" Then
Workbooks.Open filename:=myPath & WorkFile
ActiveWorkbook.SaveAs filename:= _
myPath & WorkFile & "m", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

ActiveWorkbook.Close
Kill myPath & WorkFile
End If
WorkFile = Dir()
Loop
End Sub

Sub ShowSubFolders(Folder)
For Each SubFolder In Folder.SubFolders
Set objFolder = objFSO.GetFolder(SubFolder.path)
Set colFiles = objFolder.Files
For Each objFile In colFiles
If Right(objFile.Name, 4) <> "xlsm" Then
Dim path As String
Dim filename As String
filename = objFile.Name
path = SubFolder.path & "\" & objFile.Name
Workbooks.Open filename:=path
path = SubFolder.path & "\" & "test.xlsm"

ActiveWorkbook.SaveAs filename:= _
path, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

ActiveWorkbook.Close

Kill SubFolder.path & "\" & objFile.Name
'path is nog temp file
Workbooks.Open filename:=path
'path veranderen naar originele filename met extensie "xlsm"
path = SubFolder.path & "\" & filename & "m"

ActiveWorkbook.SaveAs filename:= _
path, FileFormat:=52, CreateBackup:=False
'xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close
End If
Next
ShowSubFolders SubFolder
Next
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function

Is it posible to also change in SUBFolders?
Or where can I find it on the internet?

Thanks in advance.

Bob Phillips
02-07-2010, 02:10 PM
Dim result As String
Dim objFSO As Object

Sub Start()

Set objFSO = CreateObject("Scripting.FileSystemObject")

result = BrowseForFolder

Select Case result
Case Is = False
result = "an invalid folder!"
Case Else
End Select
TrandformAllXLSFilesToXLSM (result)
End Sub

Public Sub TrandformAllXLSFilesToXLSM(FilePath As String)
Dim mFile As Object
Dim fldr As Object
Dim sfldr As Object

Set fldr = objFSO.getFolder(FilePath & "\")
For Each mFile In fldr.Files

If mFile.Type Like "*Excel*" And Right$(mFile.Name, 4) <> "xlsm" Then

Workbooks.Open Filename:=mFile.Path
ActiveWorkbook.SaveAs Filename:= _
mFile.Path & "m", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

ActiveWorkbook.Close
Kill FilePath & mFile.Name
End If
Next mFile

For Each sfldr In fldr.subfolders

Call TrandformAllXLSFilesToXLSM(FilePath & "\" & sfldr.Name)
Next sfldr

End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function

Pinokkio
02-07-2010, 02:36 PM
Thans for reply,

Gives an Error 53 (can't find the file) - Kill FilePath & mFile.Name

Work with xl2007.

Bob Phillips
02-07-2010, 03:54 PM
The one bit I didn't test :doh:

Change that line to



Kill FilePath & Application.PathSeparator & mFile.Name

Pinokkio
02-08-2010, 10:35 AM
Works great now, many thanks.

P.