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.
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.