Determine if file exists - excel

I want to open workbook up to variable in the archive list.
If I don't have the file in the archive, I want it to show a message box, but it did not work.
strVariable = Left(PictureNo, 4)
d = "Teknik Resim Arsiv Listesi_" & strVariable & ".xls"
Dim Ret
Ret = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & d)
If Ret = False Then
MsgBox "Not Found"
End If

Check for the existence of the file before attempting to open it:
strVariable = Left(PictureNo, 4)
d = "Teknik Resim Arsiv Listesi_" & strVariable & ".xls"
If Dir(ThisWorkbook.Path & Application.PathSeparator & d) = "" Then
MsgBox "Not Found"
Else
Dim wb As Workbook
Set wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & d)
End If

Related

Excel won't let macro save spreadsheet with macros

I've written a spreadsheet for a small company, that has several useful functions including performing the shift rotation for their full- and part-time employees, generates a list of possibly understaffed shifts and then prompts the user to save the updated file with a suggested new name. However I code it, I run into one of 2 problems:
The macro is able to save the spreadsheet without the macros - but then subsequent adjustments to the scheduling won't be reflected in the list of understaffed shifts because the macro isn't saved with the file.
The macro attempts to save the spreadsheet with the macros - but returns an error message, regardless of the parameters I pass the Workbook.SaveAs method. I would have expected that if I saved it with FileFormat=xlOpenXMLWorkbookMacroEnabled and a .xlsm suffix, then there'd be no problem. Instead I get an error message (sorry I don't have it in front of me) to the effect that Excel can't save the spreadsheet in that format. If I manually save the spreadsheet in that format, I have no problem.
I suspect this has to do with safeguards against VBA viruses, but I'm not sure how else to create the functionality I need. The office staff are not computer professionals by any stretch of the imagination, so I need to keep it simple. We also need a record of past rotations, so staff can look back on previous adjustments. At the same time, they want to be able to make adjustments to the current rotation and then re-generate the list of understaffed shifts, or clear it and start again.
I've checked similar forums and posts and the thing that usually does the trick, making sure the filename suffix is in line with the FileType parameter, doesn't seem to have worked here. Any suggestions?
Public Sub SaveSchedule()
Dim SaveName As String
Dim SaveDlg As Office.FileDialog
With Excel.ActiveWorkbook.Worksheets("Workers")
SaveName = "Shift Schedule " & Year(.Range("StartDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("StartDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("StartDate")), 2)
SaveName = SaveName & " to " & Year(.Range("EndDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("EndDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("EndDate")), 2)
SaveName = SaveName & ".xlsm" '".xlsx"
End With
Set SaveDlg = Application.FileDialog(msoFileDialogSaveAs)
With SaveDlg
.AllowMultiSelect = False
.ButtonName = "Save"
.InitialFileName = SaveName
.Title = "Save new shift schedule"
If .Show() Then
Excel.ActiveWorkbook.SaveAs .SelectedItems(1), xlOpenXMLWorkbookMacroEnabled ' xlOpenXMLWorkbook
Else
MsgBox SaveName & " should be saved as a new file.", vbCritical + vbApplicationModal + vbOKOnly, "New Schedule not saved."
End If
End With
End Sub
The issue with Application.FileDialog(msoFileDialogSaveAs) is that if you do not specify a correct filter index then it will either pick the first one
OR the one which was used last. This can be resolved by specifying .FilterIndex. For .xlsm. the filter index is 2.
Try this
With SaveDlg
.AllowMultiSelect = False
.ButtonName = "Save"
.InitialFileName = SaveName
.FilterIndex = 2 '<~~ FILTER INDEX
.Title = "Save new shift schedule"
If .Show() Then
Excel.ActiveWorkbook.SaveAs .SelectedItems(1), xlOpenXMLWorkbookMacroEnabled ' xlOpenXMLWorkbook
Else
MsgBox SaveName & " should be saved as a new file.", vbCritical + vbApplicationModal + vbOKOnly, "New Schedule not saved."
End If
End With
OTHER OPTIONS
OPTION 1 : Directly save the file
Dim SaveName As String
With Excel.ActiveWorkbook.Worksheets("Workers")
SaveName = "Shift Schedule " & Year(.Range("StartDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("StartDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("StartDate")), 2)
SaveName = SaveName & " to " & Year(.Range("EndDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("EndDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("EndDate")), 2)
SaveName = SaveName & ".xlsm" '".xlsx"
End With
Excel.ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
OPTION 2 : Let user only choose a folder
In this option user will not be able to modify the file name and extension. They can only choose the Save As folder.
Option Explicit
Sub Sample()
Dim SaveName As String
Dim Extn As String
Dim FlFormat As Integer
With Excel.ActiveWorkbook.Worksheets("Workers")
SaveName = "Shift Schedule " & Year(.Range("StartDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("StartDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("StartDate")), 2)
SaveName = SaveName & " to " & Year(.Range("EndDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("EndDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("EndDate")), 2)
SaveName = SaveName
End With
'~~> File extenstion. I have shown only for 2
'~~> Tweak for rest
Extn = ".xlsm" '".xlsx"
If Extn = ".xlsm" Then
FlFormat = xlOpenXMLWorkbookMacroEnabled
ElseIf Extn = ".xlsx" Then
FlFormat = xlOpenXMLWorkbook
End If
'~~> Folder Browser
Dim Ret As Variant
Ret = BrowseForFolder
If Ret = False Then Exit Sub
Dim Filepath As String
Filepath = Ret
If Right(Filepath, 1) <> "\" Then Filepath = Filepath & "\"
SaveName = Filepath & SaveName & Extn
Excel.ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=FlFormat
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 CleanExit
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo CleanExit
Case Else
GoTo CleanExit
End Select
Exit Function
CleanExit:
BrowseForFolder = False
End Function
SaveAs Dialog
Public Sub SaveSchedule()
Const PROC_TITLE As String = "Save New Shift Schedule"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Workers")
Dim SaveName As String
With ws
SaveName = "Shift Schedule " & Format(.Range("StartDate"), "YYYY-MM-DD")
SaveName = SaveName & " to " & Format(.Range("EndDate"), "YYYY-MM-DD")
SaveName = SaveName & ".xlsm"
End With
Dim SaveDlg As Office.FileDialog
Set SaveDlg = Application.FileDialog(msoFileDialogSaveAs)
With SaveDlg
.AllowMultiSelect = False
.ButtonName = "SaveAs"
.FilterIndex = 2 ' .xlsm
.InitialFileName = SaveName
.Title = PROC_TITLE
Dim FilePath As String
If .Show Then
FilePath = .SelectedItems(1)
If StrComp(Right(FilePath, 5), ".xlsm", vbTextCompare) = 0 Then
Application.DisplayAlerts = False ' overwrite, no confirmation
wb.SaveAs FilePath, xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
Else ' not '.xlsm'
MsgBox "The file needs to be saved with an '.xlsm' extension." _
& vbLf & "File not saved.", _
vbCritical + vbApplicationModal, PROC_TITLE
End If
Else ' canceled
MsgBox SaveName & " not saved.", _
vbCritical + vbApplicationModal, PROC_TITLE
End If
End With
End Sub

Loop to save worksheet in new workbook

I want to run through a specific sheet (from & to) save those ws as a new file in a folder, if the folder doesn't exist then create.
I'm able to do it to one sheet.
ActiveSheet.Next.Select
If Range("F3").Value = "" Then
Windows("Import OT.xlsm").Activate
Sheets("Cash").Select
Dim filename101 As String
Dim path101 As String
Application.DisplayAlerts = False
path101 = Environ("UserProfile") & "\Dropbox\A271\5 Oppgjor\" & 2020 & "\"
filename101 = Range("B1").Value & ".xlsx"
ActiveWorkbook.SaveAs path101 & Range("A2") & "\" & Range("A1") & " " & filename101,xlOpenXMLWorkbook
Application.DisplayAlerts = True
Else
Cells.Select
Range("F3").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Dim Path1 As String
Dim fpathname1 As String
Path1 = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\"
fpathname1 = Path1 & Range("F3") & "\" & Range("F2") & " " & Range("B3") & ".xlsx"
path01 = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\" & Range("F3")
Dim path001 As String
Dim Folder As String
Folder = Dir(path01, vbDirectory)
If Folder = vbNullString Then
VBA.FileSystem.MkDir (path01)
ActiveWorkbook.SaveAs filename:=fpathname1, FileFormat:=51
ActiveWorkbook.Close
Sheets("Cash").Select
Else
ActiveWorkbook.SaveAs filename:=fpathname1, FileFormat:=51
ActiveWorkbook.Close
Sheets("Cash").Select
End If
End If
End Sub
I want this as a loop is because I have a few tens of sheets. For it to work I think I need to write it specific time, but with loop I learned I don't need to do that.
Excel file sheet
https://onedrive.live.com/view.aspx?resid=AF6FF2618C09AC74!29027&ithint=file%2cxlsx&authkey=!AHcJjYCu8D0NTNY
According to your comment where you wrote the steps:
Read the comments
Try to run the code using F8 key and see where you need to change it.
As you're learning, please note to first write the steps in plain English Norsk and then develop your code.
See how I just followed your steps with readable code.
Code:
Public Sub GenerateCustomersFiles()
' 1) Active sheet (oppgjør 1-20)
Dim targetSheet As Worksheet
For Each targetSheet In ThisWorkbook.Sheets
' Check only sheets with string in name
If InStr(targetSheet.Name, "Oppgjør") > 0 Then
' 2) look if value in F3 is empty
If targetSheet.Range("F3").Value = vbNullString Then
' 3) if it is, do select "cash" sheet and save this file (its name and path are given above what it should be named)
Dim fileName As String
Dim filePath As String
Dim folderPath As String
folderPath = Environ("UserProfile") & "\Dropbox\A271\5 Oppgjor\" & 2020 & "\"
fileName = targetSheet.Range("B1").Value & ".xlsx"
filePath = folderPath & targetSheet.Range("A2") & "\" & targetSheet.Range("A1") & " " & fileName
ThisWorkbook.Worksheets("Cash").Select
ThisWorkbook.SaveAs filePath, xlOpenXMLWorkbook
Else
' 4) if it doesn't, do open selected sheet to a new workbook and save that in clients name folder (folder and path given above in code section)
folderPath = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\" & targetSheet.Range("F3")
fileName = targetSheet.Range("F2") & " " & targetSheet.Range("B3") & ".xlsx"
filePath = folderPath & "\" & fileName
' 5) check if clients folder exist or not for the file to be saved in.
' if folder doesnt exist,
' create new and save file there.
CreateFoldersInPath folderPath
' if folder exist just save the file there
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Add
targetSheet.Copy before:=targetWorkbook.Sheets(1)
targetWorkbook.SaveAs filePath, 51
targetWorkbook.Close
End If
End If
Next targetSheet
End Sub
' Credits: https://stackoverflow.com/a/31034201/1521579
Private Sub CreateFoldersInPath(ByVal targetFolderPath As String)
Dim strBuildPath As String
Dim varFolder As Variant
If Right(targetFolderPath, 1) = "\" Then targetFolderPath = Left(targetFolderPath, Len(targetFolderPath) - 1)
For Each varFolder In Split(targetFolderPath, "\")
If Len(strBuildPath) = 0 Then
strBuildPath = varFolder & "\"
Else
strBuildPath = strBuildPath & varFolder & "\"
End If
If Len(Dir(strBuildPath, vbDirectory)) = 0 Then MkDir strBuildPath
Next varFolder
'The full folder path has been created regardless of nested subdirectories
'Continue with your code here
End Sub
Let me know how it goes

How to save the active workbook in another folder in Excel VBA?

I am trying to automatically save my active workbook into another folder on my computer and if there is already a file with the name of my workbook in that folder, then it should be saved with "_v1"/"_v2" and so on at the end of its name.
I have found this code but it works just for the current folder, where the workbook is saved.
Sub SaveNewVersion_Excel()
Dim FolderPath As String
Dim myPath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
TestStr = ""
Saved = False
x = 2
VersionExt = "_v"
On Error GoTo NotSavedYet
myPath = "O:\Operations\Department\Data Bank Coordinator\_PROJECTS_\QC BeadRegion Check\Multi Ref Archiv"
myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
FolderPath = Left(myPath, InStrRev(myPath, "\"))
SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
On Error GoTo 0
If InStr(1, myFileName, VersionExt) > 1 Then
myArray = Split(myFileName, VersionExt)
SaveName = myArray(0)
Else
SaveName = myFileName
End If
If FileExist(FolderPath & SaveName & SaveExt) = False Then
ActiveWorkbook.saveAs FolderPath & SaveName & SaveExt
Exit Sub
End If
Do While Saved = False
If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
ActiveWorkbook.saveAs FolderPath & SaveName & VersionExt & x & SaveExt
Saved = True
Else
x = x + 1
End If
Loop
Exit Sub
NotSavedYet:
MsgBox "This file has not been initially saved. " & _
"Cannot save a new version!", vbCritical, "Not Saved To Computer"
End Sub
Function FileExist(FilePath As String) As Boolean
Dim TestStr As String
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
It works for the current folder but when I change the folder path it doesn't work.
I would very much appreciate it if you could help me.
Thanks!
Sergiu
I've assumed the new folder is "D:_PROJECTS_\Multi Ref Archiv" and that if the existing file is zzzz_v07.xlsm then you want this saved as zzzz_v08.xlsm even when there are no previous versions in the folder. I added the leading zero so they sort nicely!
Sub SaveNewVersion_Excel2()
Const FOLDER = "D:\_PROJECTS_\Multi Ref Archiv" ' new location
Const MAX_FILES = 99
Dim oFSO As Object, oFolder As Object, bOK As Boolean, res As Variant
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim sFilename As String, sFilename_v As String
' filename only
sFilename = ThisWorkbook.Name
' check folder exists
If Not oFSO.folderexists(FOLDER) Then
bOK = MsgBox(FOLDER & " does not exist. Do you want to create ?", vbYesNo, "Confirm")
If bOK Then
oFSO.createFolder FOLDER
MsgBox "OK created " & FOLDER, vbInformation
Else
Exit Sub
End If
End If
' get next name
sFilename_v = Next_v(sFilename)
' check if exists
Dim i As Integer: i = 1
Do While oFSO.fileexists(FOLDER & "\" & sFilename_v) = True And i <= MAX_FILES
i = i + 1
sFilename_v = Next_v(sFilename_v)
Loop
' check loop ok
If i > MAX_FILES Then
MsgBox "More than " & MAX_FILES & " files already exist", vbExclamation
Exit Sub
End If
sFilename_v = FOLDER & "\" & sFilename_v
' confirm save
res = MsgBox("Do you want to save to " & sFilename_v, vbYesNo, "Confirm")
If res = vbYes Then
ActiveWorkbook.SaveAs sFilename_v
MsgBox "Done", vbInformation
End If
End Sub
Function Next_v(s As String)
Const ver = "_v"
Dim i As Integer, j As Integer, ext As String, rev As Integer
i = InStrRev(s, ".")
j = InStrRev(s, ver)
ext = Mid(s, i)
' increment existing _v if exists
If j > 0 Then
rev = Mid(s, j + 2, i - j - 2)
s = Left(s, j - 1)
Else
rev = 0
s = Left(s, i - 1)
End If
Next_v = s & ver & Format(rev + 1, "00") & ext
End Function
You can move all of the logic out to a separate function, then you only need to call that to get the "correct" name to save as.
'Pass in the full path and filename
' Append "_Vx" while the passed filename is found in the folder
' Returns empty string if the path is not valid
Function NextFileName(fPath As String)
Const V As String = "_V"
Dim fso, i, p, base, ext
Set fso = CreateObject("scripting.filesystemobject")
'valid parent folder?
If fso.folderexists(fso.GetParentFolderName(fPath)) Then
p = fPath
ext = fso.getextensionname(p)
base = Left(p, Len(p) - (1 + Len(ext))) 'base name without extension
i = 1
Do While fso.fileexists(p)
i = i + 1
p = base & (V & i) & "." & ext
Loop
End If
NextFileName = p
End Function

Use a match function to find the text to use as file name

I am trying to use a match function to reference a cell which contains the new file name.
Sub SaveAs()
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook
FPath = "\\G:\Exceptions"
FName = (Application.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0, 2)) & ".xls"
If Dir(FPath & "\" & FName) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
ThisWorkbook.SaveAs filename:=FPath & "\" & FName
End If
End Sub
Can this be done or am I better to find another way to do this?
Following on Scott's answer:
A first Error is with your Match.
Application.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0, 2))
needs to become
Application.Worksheetfunction.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0)
Also Match returns only a long so you need to add Cells() to find the name you need
Cells(Application.Worksheetfunction.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0),2).value
gives you the name you need
Now if you add the case where the match is not found you end up with this code:
Sub SaveAs()
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook
Dim Mtch As Long
FPath = "\\G:\Exceptions"
Mtch = Application.WorksheetFunction.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0)
FName = Cells(Application.WorksheetFunction.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0), 2) & ".xls"
MsgBox FName
If Not IsError(Mtch) Then
If Dir(FPath & "\" & Worksheets("Sheet 1").Cells(Mtch, 1).Value) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName
End If
Else
MsgBox "the value not found in the column"
End If
End Sub
Alternatively you can also find the Row like this:
Mtch = Findval("TEST", Range("A1:A42"))
MsgBox Mtch
FName = Cells(Application.WorksheetFunction.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0), 2) & ".xls"
MsgBox FName
If Not IsError(Mtch) Then
If Dir(FPath & "\" & Worksheets("Sheet 1").Cells(Mtch, 1).Value) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName
End If
Else
MsgBox "the value not found in the column"
End If
End Sub
Function Findval(VALUESEARCHED As String, ra As Range) As Variant
Dim A As Range
Set A = ra.Find(What:=VALUESEARCHED, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Findval = A.Row
End Function
Match returns a Long, the relative location in the 1 dimensional range. You will need to use that number with something else, like Cells() to return the actual name.
Sub SaveAs()
Dim Mtch as Long
Dim FPath As String
Dim NewBook As Workbook
FPath = "\\G:\Exceptions"
Mtch = (Application.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0)) & ".xls"
If Dir(FPath & "\" & Worksheets("Sheet 1").Cells(Mtch,2).Value) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
ThisWorkbook.SaveAs filename:=FPath & "\" & FName
End If
End Sub
Now another thing. You will want to deal with the error if a match is not found:
Sub SaveAs()
Dim Mtch as Variant
Dim FPath As String
Dim NewBook As Workbook
FPath = "\\G:\Exceptions"
Mtch = (Application.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0)) & ".xls"
If not iserror(mtch) then
If Dir(FPath & "\" & Worksheets("Sheet 1").Cells(Mtch,2).Value) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
ThisWorkbook.SaveAs filename:=FPath & "\" & FName
End If
Else
msgbox "the value not found in the column
End if
End Sub

excel to csv using visual studio

I'm trying to convert my excel file to csv using visual studio and I'm having trouble converting it. I have looped my code to go through .xls or .xlsx file in a folder and convert each one of them to csv. However, I'm having no results at all :(
Textbox1.Text is the folder selected and Textbox2.Text is the destination folder.
Anyone can help me on this?
Here is my code:
Dim xls As Excel.Application
Dim strFile As String, strPath As String
xls = New Excel.Application
strPath = TextBox1.Text
strFile = Dir(strPath & "*.xls")
While strFile <> ""
xls.Workbooks.Open(strPath & strFile)
xls.ActiveWorkbook.SaveAs(Filename:=Replace(TextBox2.Text & strFile, ".xls", ".csv"), FileFormat:=Microsoft.Office.Interop.Excel.XlFileFormat.xlTextMSDOS)
xls.Workbooks.Application.ActiveWorkbook.Close(SaveChanges:=False)
strFile = Dir()
End While
xls.Quit()
Put this inside a text file and save it as Excel2Csv.vbs. Save it inside a folder containing all your excel files. Then just simply drag your excel files onto this .vbs file.
'* Usage: Drop .xl* files on me to export each sheet as CSV
'* Global Settings and Variables
Dim gSkip
Set args = Wscript.Arguments
For Each sFilename In args
iErr = ExportExcelFileToCSV(sFilename)
' 0 for normal success
' 404 for file not found
' 10 for file skipped (or user abort if script returns 10)
Next
WScript.Quit(0)
Function ExportExcelFileToCSV(sFilename)
'* Settings
Dim oExcel, oFSO, oExcelFile
Set oExcel = CreateObject("Excel.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
iCSV_Format = 6
'* Set Up
sExtension = oFSO.GetExtensionName(sFilename)
if sExtension = "" then
ExportExcelFileToCSV = 404
Exit Function
end if
sTest = Mid(sExtension,1,2) '* first 2 letters of the extension, vb's missing a Like operator
if not (sTest = "xl") then
if (PromptForSkip(sFilename,oExcel)) then
ExportExcelFileToCSV = 10
Exit Function
end if
End If
sAbsoluteSource = oFSO.GetAbsolutePathName(sFilename)
sAbsoluteDestination = Replace(sAbsoluteSource,sExtension,"{sheet}.csv")
'* Do Work
Set oExcelFile = oExcel.Workbooks.Open(sAbsoluteSource)
For Each oSheet in oExcelFile.Sheets
sThisDestination = Replace(sAbsoluteDestination,"{sheet}",oSheet.Name)
oExcelFile.Sheets(oSheet.Name).Select
oExcelFile.SaveAs sThisDestination, iCSV_Format
Next
'* Take Down
oExcelFile.Close False
oExcel.Quit
ExportExcelFileToCSV = 0
Exit Function
End Function
Function PromptForSkip(sFilename,oExcel)
if not (VarType(gSkip) = vbEmpty) then
PromptForSkip = gSkip
Exit Function
end if
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
sPrompt = vbCRLF & _
"A filename was received that doesn't appear to be an Excel Document." & vbCRLF & _
"Do you want to skip this and all other unrecognized files? (Will only prompt this once)" & vbCRLF & _
"" & vbCRLF & _
"Yes - Will skip all further files that don't have a .xl* extension" & vbCRLF & _
"No - Will pass the file to excel regardless of extension" & vbCRLF & _
"Cancel - Abort any further conversions and exit this script" & vbCRLF & _
"" & vbCRLF & _
"The unrecognized file was:" & vbCRLF & _
sFilename & vbCRLF & _
"" & vbCRLF & _
"The path returned by the system was:" & vbCRLF & _
oFSO.GetAbsolutePathName(sFilename) & vbCRLF
sTitle = "Unrecognized File Type Encountered"
sResponse = MsgBox (sPrompt,vbYesNoCancel,sTitle)
Select Case sResponse
Case vbYes
gSkip = True
Case vbNo
gSkip = False
Case vbCancel
oExcel.Quit
WScript.Quit(10) '* 10 Is the error code I use to indicate there was a user abort (1 because wasn't successful, + 0 because the user chose to exit)
End Select
PromptForSkip = gSkip
Exit Function
End Function

Resources