Solved: xls to xlsm files.

[Pinokkio]

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]

[vba]

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
[/vba]

[Pinokkio]

Thans for reply,

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

Work with xl2007.

[Bob Phillips]

The one bit I didn't test

Change that line to

[vba]

Kill FilePath & Application.PathSeparator & mFile.Name
[/vba]

[Pinokkio]

Works great now, many thanks.

P.