I am a newbie to visual basic scripting..
I was trying to combine multiple ppt files into a single ppt using the following .vbs code.
it was supposed to create a new ppt called merged.ppt from all the ppts stored in a subfolder called PPTmerge.
But on executing I get error on line:
Set out = Application.Presentations.Open(f)
Can someone help me please...!
Const PPTMERGE_FILE = "Merged.ppt"
Const PPTMERGE_FOLDER = ".\PPTmerge"
Dim Application
Set Application=CreateObject("PowerPoint.Application")
Application.Visible = True 'must do this for merge to work
Dim first 'to open power point only once
first = True
Dim fs
Set fs=CreateObject("Scripting.FileSystemObject")
Dim folder
Set folder = fs.GetFolder(PPTMERGE_FOLDER)
Dim out
Dim f
Dim ff
For Each ff in folder.Files
f = PPTMERGE_FOLDER + "\" + ff.Name
If first Then
Dim p
Set out = Application.Presentations.Open(f)
out.SaveAs PPTMERGE_FOLDER + "\..\" + PPTMERGE_FILE
first = False
Else
out.Slides.InsertFromFile f, out.Slides.Count
End If
Next
If Not first Then
out.Save
out.SlideShowSettings.Run
'out.Close
End If
Set folder = Nothing
Set out = Nothing
Set folder = Nothing
'Application.Quit
Set Application = Nothing
You haven't specified the full path name.
Try const pptmerge_folder = "full path name here"
The code on line 2.
Related
I'm trying to write a script for a while now but it seems that one part of it just does not work.
Situation: I need a VB script that can use any LibreOffice (/ OpenOffice) Calc (3.5.4 in my case) installation on any Windows XP or 7 system for export of xls to csv (as many csv files as there are sheets in the xls). It has to be VBS and LibreOffice in this case. No macro installed, everything controlled externally by vbscript.
So, first step was to use the macro recorder in order to get the right filter settings.
StarBasic macro:
dim document as object
dim dispatcher as object
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
dim args1(2) as new com.sun.star.beans.PropertyValue
args1(0).Name = "URL"
args1(0).Value = "file:///C:/Users/lutz/Desktop/test.csv"
args1(1).Name = "FilterName"
args1(1).Value = "Text - txt - csv (StarCalc)"
args1(2).Name = "FilterOptions"
args1(2).Value = "9,0,76,1,,0,false,true,true"
dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1())
This macro (in LibreOffice) writes a CSV of the current sheet (after LO telling me that only the current sheet will be saved), encoding UTF-8, field separator Tab, no text separator. This works.
I tried to get this to work in my vbs but it absolutely did not. So I searched a lot in OpenOffice and LibreOffice forums, here at stackoverflow, etc. and used another method.
Problem: Everytime it saves the file(s) it saves them as ODS, no matter which filter or filter options I use. It always saves to zipped OpenDocument. I tried numerous Filters, even PDF. It seems that it works with pdf when I only use the FilterName property but somehow it doesn't work anymore. And I don't know why.
The code:
' Scripting object
Dim wshshell
' File system object
Dim objFSO
' OpenOffice / LibreOffice Service Manager
Dim objServiceManager
' OpenOffice / LibreOffice Desktop
Dim objDesktop
' Runcommand, if script does not run with Cscript
Dim runcommand
Dim Path
Dim Savepath
Dim Filename
Dim url
Dim args0(0)
Dim args1(3)
' Create File system object
Set wshshell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
' If not run in cscript, run in cscript
if instr(1, wscript.fullname, "cscript.exe")=0 then
runcommand = "cscript //Nologo xyz.vbs"
wshshell.run runcommand, 1, true
wscript.quit
end if
' If files present, run Calc
If objFSO.GetFolder(".").Files.Count>0 then
Set objServiceManager = WScript.CreateObject("com.sun.star.ServiceManager")
' Create Desktop
Set objDesktop = objServiceManager.createInstance("com.sun.star.frame.Desktop")
else
' If no files in directory
wscript.echo "No files found!"
wscript.quit
End If
on error resume next
bError=False
For each File in objFSO.GetFolder(".").Files
if lcase(right(File.Name,3))="xls" then
' Access file
url = ConvertToURL(File.Path)
objDesktop = GlobalScope.BasicLibraries.loadLIbrary( "Tools" )
Set args0(0) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set objDocument = objDesktop.loadComponentFromURL(url, "_blank", 0, args0 )
' Read filenames without extension or path
Path = ConvertToURL( File.ParentFolder ) & "/"
Filename = objFSO.GetBaseName( File.Path )
Savepath = ConvertToURL( File.ParentFolder )
' set arguments
Set args1(0) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args1(1) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args1(2) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
sFilterName = "Text - txt - csv (StarCalc)"
sFilterOptions = "9,0,76,1,,0,false,true,true"
sOverwrite = True
Set args1(0) = MakePropertyValue( "FilterName", sFilterName )
Set args1(1) = MakePropertyValue( "FilterOptions", sFilterOptions )
Set args1(2) = MakePropertyValue( "Overwrite", sOverwrite )
' Save every sheet in separate csv file
objSheets = objDocument.Sheets
For i = 0 to objDocument.Sheets.getcount -1
objSheet = objDocument.Sheets.getByIndex(i)
Call objDocument.CurrentController.setActiveSheet(objSheet)
Call objDocument.storeToURL( ConvertToURL( File.ParentFolder & "\" & Filename & "_" & objDocument.sheets.getByIndex(i).Name & ".csv" ), args1 )
Next
' Close document
objDocument.close(True)
Set objDocument = Nothing
Path = ""
Savepath = ""
Filename = ""
Else
End If
Next
' Close / terminate LibreOffice
objDesktop.terminate
Set objDesktop = nothing
Set objServiceManager = nothing
The function ConvertToUrl is not listed here. It is a vbscript function that converts Windows paths to URL paths (file:/// etc.). It is tested and works.
What I also tried:
Saving in ods first (StoreAsUrl) then try to save in different format.
Use MakePropertyValue( "SelectionOnly", true )
None of that worked nor did it combined. I used http://extensions.services.openoffice.org/de/project/OOcalc_multi_sheets_export as a source of inspiration. But it is a macro, not direct access from an external vb script.
It seems that the problem is a general one with StoreToUrl or the properties / arguments:
Even FilterName "writer_pdf" or "Calc MS Excel 2007 XML" don't work. Problem is: I don't know what's the culprit here. The settings that the macro recorder uses are the same and if one uses the macro directly in LibreOffice it works.
Maybe someone knows what needs to get changed in the code or how I can get the dispatcher used in the macro to work.
Thank you for your help in advance!
Ok, I found the solution after days of research and tiny little information scattered everywhere. I hope that this code will serve someone well:
' Variables
Dim wshshell ' Scripting object
Dim oFSO ' Filesystem object
Dim runcommand ' Runcommand, if not run in Cscript
Dim oSM ' OpenOffice / LibreOffice Service Manager
Dim oDesk ' OpenOffice / LibreOffice Desktop
Dim oCRef ' OpenOffice / LibreOffice Core Reflections
Dim sFileName ' Filename without extension
Dim sLoadUrl ' Url for file loading
Dim sSaveUrl ' Url for file writing
Dim args0(0) ' Load arguments
' Create file system object
Set wshshell = CreateObject("Wscript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
' If not run in cscript, run in cscript
if instr(1, wscript.fullname, "cscript.exe")=0 then
runcommand = "cscript //Nologo xyz.vbs"
wshshell.run runcommand, 1, true
wscript.quit
end if
' If there are files, start Calc
If oFSO.GetFolder(".").Files.Count>0 then
' If no LibreOffice open -> run
Set oSM = WScript.CreateObject("com.sun.star.ServiceManager")
' Create desktop
Set oDesk = oSM.createInstance("com.sun.star.frame.Desktop")
Set oCRef = oSM.createInstance( "com.sun.star.reflection.CoreReflection" )
else
' If no files in directory
wscript.quit
End If
' Error handling
on error resume next
' CSV settings for saving of file(s)
sFilterName = "Text - txt - csv (StarCalc)"
sFilterOptions = "9,0,76,1,,0,false,true,true"
sOverwrite = True
' load component for file access
oDesk = GlobalScope.BasicLibraries.loadLIbrary( "Tools" )
' load argument "hidden"
Set args0(0) = oSM.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args0(0) = MakePropertyValue("Hidden", True)
For each oFile in oFSO.GetFolder(".").Files
if lcase(right(oFile.Name,3))="xls" then
' open file
sLoadUrl = ConvertToURL(oFile.Path)
Set oDoc = oDesk.loadComponentFromURL(sLoadUrl, "_blank", 0, args0 )
' read filename without extension or path
sFileName = oFSO.GetBaseName( oFile.Path )
' save sheets in CSVs
For i = 0 to oDoc.Sheets.getcount -1
oActSheet = oDoc.CurrentController.setActiveSheet( oDoc.Sheets.getByIndex(i) )
sSaveUrl = ConvertToURL( oFile.ParentFolder & "\" & sFileName & "_" & oDoc.sheets.getByIndex(i).Name & ".csv" )
saveCSV oSM, oDoc, sSaveUrl, sFilterName, sFilterOptions, sOverwrite
Next
' Close document
oDoc.close(True)
Set oDoc = Nothing
Set oActSheet = Nothing
sFileName = ""
sLoadUrl = ""
sSaveUrl = ""
Else
End If
Next
' Close LibreOffice
oDesk.terminate
Set oDesk = nothing
Set oSM = nothing
Function ConvertToURL(sFileName)
' Convert Windows pathnames to url
Dim sTmpFile
If Left(sFileName, 7) = "file://" Then
ConvertToURL = sFileName
Exit Function
End If
ConvertToURL = "file:///"
sTmpFile = oFSO.GetAbsolutePathName(sFileName)
' replace any "\" by "/"
sTmpFile = Replace(sTmpFile,"\","/")
' replace any "%" by "%25"
sTmpFile = Replace(sTmpFile,"%","%25")
' replace any " " by "%20"
sTmpFile = Replace(sTmpFile," ","%20")
ConvertToURL = ConvertToURL & sTmpFile
End Function
Function saveCSV( oSM, oDoc, sSaveUrl, sFilterName, sFilterOptions, sOverwrite )
' Saves the open document resp. active sheet in a single file
Dim aProps( 2 ), oProp0, oProp1, oProp2, vRet
' Set filter name and write into property array
Set oProp0 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp0.Name = "FilterName"
oProp0.Value = sFilterName
Set aProps( 0 ) = oProp0
' Set filter options and write into property array
Set oProp1 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp1.Name = "FilterOptions"
oProp1.Value = sFilterOptions
Set aProps( 1 ) = oProp1
' Set file overwrite and write into property array
Set oProp2 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp2.Name = "Overwrite"
oProp2.Value = sOverwrite
Set aProps( 2 ) = oProp2
' Save
vRet = oDoc.storeToURL( sSaveUrl, aProps )
End Function
I hope that at least this small contribution from me helps others.
I have written the following code, tested it, and it works. I then literally copied and pasted it into a larger program as a sub. I'm getting a Type mismatch on the Split Function now. I copied & pasted it out of the subroutine and into a new file and it works again. Any help on why this is happening would be appreciated.
Dim oFSO
Dim oNew
Dim oExcel
Dim Folder2
Dim oFile
Dim File, Line
Dim f, fc
Dim x, y, e, i, j
Dim objSheet, TFile, TSheet
Dim TextLine
'Calls Excel into session and leaves it running in the background
Set oExcel = CreateObject("Excel.Application")
oExcel.Visible = False
oExcel.DisplayAlerts = False
'Opens the selected excel file and then lets the user choose the folder to be updated to it
Set oNew = oExcel.Workbooks.Open(BrowseForFolder("Select Excel File to Update"))
Set oFSO = CreateObject("Scripting.FileSystemObject")
Folder2 = BrowseForFolder("Choose file containing updated CSV's")
Set f = oFSO.GetFolder(Folder2)
Set fc = f.Files
oNew.Activate
'This loops through every file in the folder, compares the name of the file to the names
'of the sheets in the excel file and overwrites the data to on the spreadsheet
For Each oFile In fc
TFile = Left(oFile.Name,InStr(oFile.Name,"-")-1)
For i =1 To oNew.Sheets.Count
j = InStr(oNew.Sheets(i).Name,"-")-1
TSheet = Left(oNew.Sheets(i).Name,j)
if TSheet = TFile Then
oNew.Sheets(i).Activate
set objSheet = oNew.ActiveSheet
objSheet.Name = Left(oFile.Name,InStr(oFile.Name,".")-1)
Set File = oFSO.OpenTextFile(oFile)
x = 1
Do While File.AtEndofStream <> True
Line = File.Readline
TextLine = Split(Line,",")
y = 1
For Each e In TextLine
objSheet.Cells(x, y) = e
y = y+1
Next
x=x+1
Loop
End If
Next
Next
MsgBox "Spreadsheet Updated! New spreadsheet is located in Documents"
' Save merged result as an Excel file in Documents
oNew.SaveAs "SAPDASHBOARD", 51
oNew.Close
' Shut down Excel
oExcel.Quit
Set oExcel = Nothing
Set oNew = Nothing
Set oFile = Nothing
Function BrowseForFolder(title)
Dim shell : Set shell = CreateObject("Shell.Application")
Dim file : Set file = shell.BrowseForFolder(0, title, &H4000,0)
If file is Nothing Then
WScript.Echo "No Folder Selected"
WScript.Quit
End IF
BrowseForFolder = file.self.Path
End Function
I actually figured it out. The problem wasn't this portion of the script, it was the fact that one of the other subroutines in the big program was named Split. So when it tried to run the builtin function "Split" it tried to call the subroutine. That's a mistake I won't be making again
I'm not really a programmer by trade, so forgive me if I'm not aware of any standard debugging tools.
I have what I thought was a very simple VBScript (just a txt file saved with a .vbs extension):
Const wdDoNotSaveChanges = 0
Const wdRevisionsViewFinal = 0
Const wdFormatPDF = 17
Dim arguments
Set arguments = WScript.Arguments
Function DOC2PDF(sDocFile)
Dim fso ' As FileSystemObject
Dim wdo ' As Word.Application
Dim wdoc ' As Word.Document
Dim wdocs ' As Word.Documents
Set fso = CreateObject("Scripting.FileSystemObject")
sDocFile = fso.GetAbsolutePathName(sDocFile)
sPdfFile = fso.GetParentFolderName(sDocFile) + "\" + fso.GetBaseName(sDocFile) + ".pdf"
Set wdo = CreateObject("Word.Application")
Set wdocs = wdo.Documents
Set wdoc = wdocs.Open(sDocFile)
if fso.FileExists(sPdfFile) Then
fso.DeleteFile sPdfFile, True
End If
Set wview = wdoc.ActiveWindow.View
wview.ShowRevisionsAndComments = False
wview.RevisionsView = wdRevisionsViewFinal
wdoc.SaveAs sPdfFile, wdFormatPDF
wdo.Quit wdDoNotSaveChanges
Set fso = Nothing
Set wdo = Nothing
End Function
however, the following line is causing huge grief:
Set wdoc = wdocs.Open(sDocFile)
Sometimes the Word ActiveX object just freezes at this step. I've verified this by some super-simple debugging by putting a WriteLine after each line and seeing where it stops.
Word just sits there consuming 100% CPU, and the script never gets past that step.
How can I go about debugging to find out what the hell is going on with the Word ActiveX object and why it's just hanging and never returning?
Word might be waiting for a prompt from you. I would make Word visible and see if you can visually see what the problem is:
Set wdo = CreateObject("Word.Application")
'if memory serves, this should make Word visible
wdo.Visible = true
Set wdocs = wdo.Documents
I am trying to determine the number of files that would be copied from the source folder to the destination and then assign this value to the progressbar.max.But using the code below I get Runtime error 5, Invalid procedure call or argument at the marked position.Please Guide
Private Sub cmdCopy_Click()
Dim sFileName As String 'Source File
Dim sDirName As String 'Source Directory
Dim dDirName As String 'Destination Directory
Dim fiFileCount As Integer 'Number of Files to be copied
Dim fbFileMatch As Boolean
If prgFCount.Visible = True Then prgFCount.Visible = False
dDirName = "D:\Destination\"
sDirName = "C:\Source\"
sFileName = Dir(sDirName)
' Disable this button so the user cannot
' start another copy.
cmdCopy.Enabled = False
cmdCancel.Enabled = True
fiFileCount = 0
Do While Len(sFileName) > 0
fbFileMatch = False
If Len(Dir$(dDirName & sFileName)) > 0 Then
fbFileMatch = True
End If
If fbFileMatch = False Then
fiFileCount = fiFileCount + 1
End If
sFileName = Dir '## Error at this Point ##
Loop
If fiFileCount = 0 Then
cmdCopy.Enabled = True
cmdCancel.Enabled = False
Exit Sub
End If
prgFCount.Min = 0
prgFCount.Max = fiFileCount
prgFCount.Visible = True
End Sub
If Len(Dir$(dDirName & sFileName)) > 0 Then
You set up your directory iteration with the line:
sFileName = Dir(sDirName)
Calling the Dir function without parameters will get the next item meeting the file name pattern and attributes is retrieved. The Len(Dir$ call is screwing it up.
I would suggest rewriting your code to loop through all the files in your source folder and build a list, then loop through the list and look for matches in your destination folder.
Something like this:
...
sFileName = Dir$(sDirName)
Do While Len(sFileName) > 0
i = i + 1
ReDim Preserve strSourceFileList(i)
strSourceFileList(i) = sFileName
sFileName = Dir()
Loop
If i > 0 Then
For i = LBound(strSourceFileList) To UBound(strSourceFileList)
sFileName = Dir$(dDirName & strSourceFileList(i))
If Len(sFileName) = 0 Then
fiFileCount = fiFileCount + 1
End If
Next i
End If
...
Dir returns the name of a matching file, directory, or folder.
Calling Dir should be fine but in your case it generates the error.
You also have no loop implemented to iterrate through all the available source files.
Using the FileSystemObject is one of the options.
To use the FileSystemObject, click the Project menu option, followed by the References... menu option.
This will open the References Dialog.
Tick the box beside the reference named "Microsoft Scripting Runtime" and click OK.
Now you can declare a variable as a FileSystemObject. In addition you get access to more objects such as File, Folder, Files and more.
Using the FileSystemObject gives you access to a wide range of features.
The code below demonstrates how to get the count of files which do not exist in the destination and will be copied, using the FileSystemObject.
Private Sub cmdCopy_Click()
Dim fso As New FileSystemObject
Dim sourceFolder As Folder
Dim sourceFile As File
Dim destinationFolder As Folder
Dim filesToBeCopied As Integer
Set sourceFolder = fso.GetFolder("C:\-- Temp --\Source")
Set destinationFolder = fso.GetFolder("C:\-- Temp --\Destination")
filesToBeCopied = 0
' Iterrate through each file in the source folder.
For Each sourceFile In sourceFolder.Files
' Check if the source file exists in the destination folder
If Not (fso.FileExists(destinationFolder + "\" + sourceFile.Name)) Then
filesToBeCopied = filesToBeCopied + 1
End If
Next
End Sub
I have tested the above code and it correctly increments the count of filesToBeCopied to the expected number.
How do I save an entire VB6 project to a new folder? Modules and all. I'm in a position where I need to work with some old VB6 projects. I'd like to save them to a new folder but when I save the project, all that is saved is the vbp file. No modules, no frm files. I want to be able to save all the info to a single folder without moving each BAS file one at a time. Is this even possible?
Addition: The first 2 replies make good sense. But my problem is that the BAS modules seem to be scattered all over the place. Making Windows Explorer do the work a bit tricky. If I have to I will but was looking for an easier way.
Thanks
Given the new "addition" to the question:
Move the VBP and the files in Windows Explorer to a completely new directory.
Open the VBP in a text editor and change any absolute paths to relative paths. VBP files are simple text files, and the format is even documented in the VB6 manual.
Here's an example. This evil VBP below has many absolute paths
Type=Exe
Form=c:\who\knows\where\B_Form.frm
Module=CModule; z:\magic\mapped\network\drive\heehee\C_Module.bas
Class=DClass; x:\personal\usb\stick\D_Class.cls
It would be changed to this benign VBP, which references local copies of the files. You can use relative paths for subdirectories.
Type=Exe
Form=B_Form.frm
Module=CModule; C_Module.bas
Class=DClass; subdirectory\D_Class.cls
If you mean from within Visual Studio, I don't think you can except by doing Save As for each file...
But the simpler approach is to just use Windows Explorer and copy the whole folder structure for the solution into another folder, (or do a recursive "Get" from your source code repository to a different local destination), and then open the solution or project file in the new location... The pointers in the project file that tell Visual Studio where 5all the individual source code and other files are located are generally all stored as relative paths, relative to the folder that the project file is in...
It's been a while since I used VB6, but I'd be tempted to move them using Windows Explorer, then manually edit the VBP file to point to the new locations afterwards. If I remember right, relative paths are fine in the VBP, so you may not even need to manke any changes.
Unbind from source control, if capable/appropriate.
Check into source control as a brand new solution/project
Recursive 'get' from your SCM into a new directory.
There's your new copy.
Create a VB6 Add-in. You can download it from: http://pan.baidu.com/s/1CXO3k
Or you can use below code to create your own.
Option Explicit
Public VBInstance As VBIDE.VBE
Public Connect As Connect
Private Sub CancelButton_Click()
Connect.Hide
End Sub
Private Sub OKButton_Click()
On Error Resume Next
Dim strProject As String
Dim strPath As String
Dim strPath2 As String
Dim strFile As String
Dim strPrjFile As String
Dim rst As VbMsgBoxResult
Dim m, n As Long
Dim col2 As Collection, col As Collection
Dim vbCom As VBComponent
Dim fso As FileSystemObject
Dim ts As TextStream
Dim f1 As String, f2 As String
strProject = Me.VBInstance.ActiveVBProject.FileName
strPath = ParseFileName(strProject, strPrjFile)
strPath2 = setFolder
If strPath = "" Or strPath = strPath2 Then
MsgBox "target folder is invalid or same as the project folder. Can't copy."
Exit Sub
End If
Set col2 = New Collection
Set col = New Collection
Set fso = New FileSystemObject
Set ts = fso.CreateTextFile(strPath2 & "\wemeet.log", False)
For m = Me.VBInstance.ActiveVBProject.VBComponents.Count To 1 Step -1
Set vbCom = Me.VBInstance.ActiveVBProject.VBComponents(m)
For n = 1 To vbCom.FileCount
f1 = vbCom.FileNames(n)
ParseFileName f1, strFile
f2 = strPath2 & "\" & strFile
fso.CopyFile f1, f2
col.Add f1
col2.Add f2
ts.WriteLine "" & Now() & " [Move]: " & f1
ts.WriteLine "" & Now() & " [To ]: " & f2
ts.WriteBlankLines 1
Next
Me.VBInstance.ActiveVBProject.VBComponents.Remove vbCom
Next
For m = 1 To col2.Count
Me.VBInstance.ActiveVBProject.VBComponents.AddFile col2.Item(m)
ts.WriteLine "" & Now() & " [Add]: " & col2.Item(m)
ts.WriteBlankLines 1
Next
Me.VBInstance.ActiveVBProject.SaveAs strPath2 & "\" & strPrjFile
ts.WriteLine "" & Now() & " [SaveAs]: " & strPath2 & "\" & strPrjFile
ts.WriteBlankLines 1
ts.Close
fso.OpenTextFile strPath2 & "\wemeet.log"
Set fso = Nothing
Set col = Nothing
Set col2 = Nothing
Set vbCom = Nothing
Connect.Hide
End Sub
Private Function ParseFileName(ByVal sPath As String, ByRef sFile As String) As String
Dim fso As New FileSystemObject
If fso.FileExists(sPath) Then
ParseFileName = fso.GetParentFolderName(sPath)
sFile = fso.GetFileName(sPath)
Else
ParseFileName = ""
sFile = ""
End If
Set fso = Nothing
End Function
Private Function setFolder() As String
Dim objDlg As Object
Dim objStartFolder As Object
Set objDlg = CreateObject("Shell.Application")
Set objStartFolder = objDlg.BrowseForFolder(&H0, "Select a folder", &H10 + &H1)
If InStr(1, TypeName(objStartFolder), "Folder") > 0 Then
setFolder = objStartFolder.ParentFolder.ParseName(objStartFolder.Title).Path
End If
Set objDlg = Nothing
End Function