[VBScript] Need unicode compatibility

[ChronoStriker1]

This started out as a question in the software forum but, at this point I need the services of this part of the forum. I've don't most of what I set out to do but my script has a problem with files in the archive having unicode characters. Extraction works fine but when I pipe dir to the list.log nothing shows up. I was wondering if anyone can help me out. I would also like to only extract the file I need but in the end like I said the script works.

For those who don't want to read the other thread, the script goes through a directory, it will extract the archives I've set to a temp dir, list the names to a log to get the first file alphabetically, then it will rename that file and to the name of the archive it came from. All this so I can run visipics on the folder so I can find duplicates buy the cover.

So far as is the script helped me find 10G of duplicates.

Option Explicit

' Flags for the options parameter
Const BIF_returnonlyfsdirs   = &H0001
Const BIF_dontgobelowdomain  = &H0002
Const BIF_statustext		 = &H0004
Const BIF_returnfsancestors  = &H0008
Const BIF_editbox			= &H0010
Const BIF_validate		   = &H0020
Const BIF_browseforcomputer  = &H1000
Const BIF_browseforprinter   = &H2000
Const BIF_browseincludefiles = &H4000
Const OverwriteExisting = True


Dim folder, objFSO, objFolder, colFiles, objFile, objExtension, objShell, objLog
Dim sText, sCurPath, sTempPath, sFirstImg

sCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
sTempPath = sCurPath & "\temp"
'WScript.Echo sTempPath

folder = BrowseForFolder("Select a folder to get covers from", BIF_returnonlyfsdirs, "")
If folder = "-5" Then 
	WScript.Echo "Not possible to select files in root folder"
	WScript.Quit
Else
	If folder = "-1" Then 
		WScript.Echo "No object selected; Cancel clicked"
		WScript.Quit
	Else
		'Folder path from browsforfolder
		'WScript.Echo "Object: ", folder
	End If
End If 

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(folder)

Set objShell = CreateObject("WScript.Shell")

Set colFiles = objFolder.Files
For Each objFile in colFiles
	'Wscript.Echo objFile.Name
	objExtension = lcase(objFile)
	'Wscript.Echo objExtension
	'Wscript.Echo right(objExtension, 3)
	If right(lcase(objExtension), 3) = "zip" or right(lcase(objExtension), 3) = "cbz" _
	or right(lcase(objExtension), 3) = "cb7" or right(lcase(objExtension), 3) = "7z" _
	or right(lcase(objExtension), 3) = "lzh" or right(lcase(objExtension), 3) = "rar" _
	or right(lcase(objExtension), 3) = "cbr" or right(lcase(objExtension), 3) = "tar" _
	or right(lcase(objExtension), 3) = "cbt" then
		If Not objFSO.FolderExists(sTempPath) Then
			objFSO.CreateFolder(sTempPath)
		End If
		'Wscript.Echo objFile
		'list extract archive
		objShell.Run "%comspec% /c" & sCurPath &  "\7z.exe e " & """" & objfile _ 
		& """ -o""" & sTempPath & """ -y", 7, true
		objShell.Run "%comspec% /c dir /B " & sTempPath & "  > list.log", 7, true
		'dont think its doing anything
		'objShell.Run "cmd /u /c dir /B " & sTempPath & "  > list.log", 7, true
		'log file is now unicode but opentext isn't
		Set objLog = objFSO.OpenTextFile("list.log", 1)
			Do While Not objLog.AtEndOfStream
				sText = objLog.ReadLine
				If right(lcase(sText),3) = "jpg" or right(lcase(sText),3) = "png" _
				or right(lcase(sText),3) = "gif" or right(lcase(sText),3) = "tif" Then
					sFirstImg = sTempPath & "\" & sText
					sText = objFile.Name & "." & right(sText,3)
					'WScript.Echo sFirstImg
					'MsgBox(objFolder & "\" & sText)
					If objFSO.FileExists (sFirstImg) then
						objFSO.CopyFile sFirstImg, objFolder & "\" & sText, true
					Else
						'WScript.Echo sFirstImg
					End If
					Exit Do
				End If
			Loop
		objLog.Close
		'msgBox("Wait here")
		objFSO.DeleteFile(sCurPath & "/" & "list.log")
		objFSO.DeleteFolder sTempPath, 1
	End If
Next

WScript.Echo "Script finished"
WScript.Quit

' Using the shell's BrowseForFolder method to
' return the full path to the selected object
' title = Text shown in the dialog box
' flag = One of the values for controlling the 
'		BrowseForFolder behavior
' dir = Preselected directory (can be "")
Function BrowseForFolder(title, flag, dir)
	On Error Resume Next

	Dim oShell, oItem, tmp

	' Create WshShell object.
	Set oShell = WScript.CreateObject("Shell.Application")

	' Invoke Browse For Folder dialog box.
	Set oItem = oShell.BrowseForFolder(&H0, title, flag, dir)
	If Err.Number <> 0 Then
		If Err.Number = 5 Then
			BrowseForFolder= "-5"
			Err.Clear
			Set oShell = Nothing
			Set oItem = Nothing
			Exit Function
		End If
	End If

	' Now we try to retrieve the full path.
	BrowseForFolder = oItem.ParentFolder.ParseName(oItem.Title).Path

	' Handling: Cancel button and selecting a drive
	If Err<> 0 Then
		If Err.Number = 424 Then		   ' Handle Cancel button.
			BrowseForFolder = "-1"
		Else
			Err.Clear
			' Handle situation in which user selects a drive.
			' Extract drive letter from the title--first search
			' for a colon (:).
			tmp = InStr(1, oItem.Title, ":")
			If tmp > 0 Then		   ' A : is found; use two 
									  ' characters and add \.
				BrowseForFolder = Mid(oItem.Title, (tmp - 1), 2) & "\"
			End If
		End If
	End If

	Set oShell = Nothing
	Set oItem = Nothing
	On Error GoTo 0
End Function

'*** End

I also want to have the script skip files Ive already have the covers for. Its probably real easy but I'm not seeing it.

[ChronoStriker1]

Got it to skip ones already done, man I just need to post my previous script and I figure it out. Don't think it will be that easy for the unicode though. Also removed the extra lcase's that I had not that I know FileExists is case insensitive and that I realized I made objExtension lcase to begin with. Also in my code I figured out how to get the log file to take unicode characters but I cant get OpenTextFile to read it.

[EDIT] Now with more "useful" comments, not necessarily well spelled comments mind you.[/EDIT]

Option Explicit

' Flags for the options parameter
Const BIF_returnonlyfsdirs   = &H0001
Const BIF_dontgobelowdomain  = &H0002
Const BIF_statustext		 = &H0004
Const BIF_returnfsancestors  = &H0008
Const BIF_editbox			= &H0010
Const BIF_validate		   = &H0020
Const BIF_browseforcomputer  = &H1000
Const BIF_browseforprinter   = &H2000
Const BIF_browseincludefiles = &H4000
Const OverwriteExisting = True


Dim folder, objFSO, objFolder, colFiles, objFile, objExtension, objShell, objLog
Dim sText, sCurPath, sTempPath, sFirstImg

sCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
sTempPath = sCurPath & "\temp"
'WScript.Echo sTempPath

folder = BrowseForFolder("Select a folder to get covers from", BIF_returnonlyfsdirs, "")
If folder = "-5" Then 
	WScript.Echo "Not possible to select files in root folder"
	WScript.Quit
Else
	If folder = "-1" Then 
		WScript.Echo "No object selected; Cancel clicked"
		WScript.Quit
	Else
		'Folder path from browsforfolder
		'WScript.Echo "Object: ", folder
	End If
End If 

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(folder)

Set objShell = CreateObject("WScript.Shell")

Set colFiles = objFolder.Files
For Each objFile in colFiles
	'Wscript.Echo objFile.Name
	objExtension = lcase(objFile)
	'Wscript.Echo objExtension
	'Wscript.Echo right(objExtension, 3)
	'Check if the file is an archive
	If right(objExtension, 3) = "zip" or right(objExtension, 3) = "cbz" _
	or right(objExtension, 3) = "cb7" or right(objExtension, 3) = "7z" _
	or right(objExtension, 3) = "lzh" or right(objExtension, 3) = "rar" _
	or right(objExtension, 3) = "cbr" or right(objExtension, 3) = "tar" _
	or right(objExtension, 3) = "cbt" Then
		'Dont want to redo work so if the cover exists don't make it again
		If Not objFSO.FileExists(objFile & ".jpg") and _
		Not objFSO.FileExists(objFile & ".gif") and _
		Not objFSO.FileExists(objFile & ".png") and _
		Not objFSO.FileExists(objFile & ".tif") Then
			'If the script broke before, dont try to create the temp folder again
			If Not objFSO.FolderExists(sTempPath) Then
				objFSO.CreateFolder(sTempPath)
			End If
			'Wscript.Echo objFile
			'Extract the folder and then list its contents in list.log
			'Dir will list files alphabetically
			objShell.Run "%comspec% /c" & sCurPath &  "\7z.exe e " & """" & objfile _ 
			& """ -o""" & sTempPath & """ -y", 7, true
			objShell.Run "%comspec% /c dir /B " & sTempPath & "  > list.log", 7, true
			'dont think its doing anything
			'objShell.Run "cmd /u /c dir /B " & sTempPath & "  > list.log", 7, true
			'log file is now unicode but opentext isn't
			Set objLog = objFSO.OpenTextFile("list.log", 1)
				Do While Not objLog.AtEndOfStream
					sText = objLog.ReadLine
					'Look for first file in log thats an image
					If right(lcase(sText),3) = "jpg" or right(lcase(sText),3) = "png" _
					or right(lcase(sText),3) = "gif" or right(lcase(sText),3) = "tif" Then
						sFirstImg = sTempPath & "\" & sText
						sText = objFile.Name & "." & right(sText,3)
						'WScript.Echo sFirstImg
						'MsgBox(objFolder & "\" & sText)
						'This is here because I'm not piping unicode correcty, yet 
						If objFSO.FileExists (sFirstImg) then
							objFSO.CopyFile sFirstImg, objFolder & "\" & sText, true
						Else
							'WScript.Echo sFirstImg
						End If
						Exit Do
					End If
				Loop
			objLog.Close
			'So I can check the log and temp folder before its delted
			'msgBox("Wait here")
			'Was having problems with overwriting and it cleans up everything in the end
			objFSO.DeleteFile(sCurPath & "/" & "list.log")
			objFSO.DeleteFolder sTempPath, 1
		End If
	End If
Next

WScript.Echo "Script finished"
'Good Bye
WScript.Quit

' Using the shell's BrowseForFolder method to
' return the full path to the selected object
' title = Text shown in the dialog box
' flag = One of the values for controlling the 
'		BrowseForFolder behavior
' dir = Preselected directory (can be "")
Function BrowseForFolder(title, flag, dir)
	On Error Resume Next

	Dim oShell, oItem, tmp

	' Create WshShell object.
	Set oShell = WScript.CreateObject("Shell.Application")

	' Invoke Browse For Folder dialog box.
	Set oItem = oShell.BrowseForFolder(&H0, title, flag, dir)
	If Err.Number <> 0 Then
		If Err.Number = 5 Then
			BrowseForFolder= "-5"
			Err.Clear
			Set oShell = Nothing
			Set oItem = Nothing
			Exit Function
		End If
	End If

	' Now we try to retrieve the full path.
	BrowseForFolder = oItem.ParentFolder.ParseName(oItem.Title).Path

	' Handling: Cancel button and selecting a drive
	If Err<> 0 Then
		If Err.Number = 424 Then		   ' Handle Cancel button.
			BrowseForFolder = "-1"
		Else
			Err.Clear
			' Handle situation in which user selects a drive.
			' Extract drive letter from the title--first search
			' for a colon (:).
			tmp = InStr(1, oItem.Title, ":")
			If tmp > 0 Then		   ' A : is found; use two 
									  ' characters and add \.
				BrowseForFolder = Mid(oItem.Title, (tmp - 1), 2) & "\"
			End If
		End If
	End If

	Set oShell = Nothing
	Set oItem = Nothing
	On Error GoTo 0
End Function

'*** End

Edited November 22, 2009 by ChronoStriker1

[ChronoStriker1]

F yeah, Unicode support!

So at this point I'm done unless anyone has any suggestion.

'Script to get covers from comic archives
'by ChronoStriker1
'Feel free to use or modify for your own uses
'Requires 7zip, specifically 7z.exe in the dir its running from
'If you modify it in any usefull way please let me know
'Hell, if you find it usefull let me know
'Send an email to [email protected]

Option Explicit

' Flags for the options parameter
Const BIF_returnonlyfsdirs   = &H0001
Const BIF_dontgobelowdomain  = &H0002
Const BIF_statustext		 = &H0004
Const BIF_returnfsancestors  = &H0008
Const BIF_editbox			= &H0010
Const BIF_validate		   = &H0020
Const BIF_browseforcomputer  = &H1000
Const BIF_browseforprinter   = &H2000
Const BIF_browseincludefiles = &H4000
Const OverwriteExisting = True
Const ForReading = 1
Const TristateTrue = -1


Dim folder, objFSO, objFolder, colFiles, objFile, objExtension, objShell, objLog
Dim sText, sCurPath, sTempPath, sFirstImg, sTextStream

sCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
sTempPath = sCurPath & "\temp"
'WScript.Echo sTempPath

folder = BrowseForFolder("Select a folder to get covers from", BIF_returnonlyfsdirs, "")
If folder = "-5" Then 
	WScript.Echo "Not possible to select files in root folder"
	WScript.Quit
Else
	If folder = "-1" Then 
		WScript.Echo "No object selected; Cancel clicked"
		WScript.Quit
	Else
		'Folder path from browsforfolder
		'WScript.Echo "Object: ", folder
	End If
End If 

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(folder)

Set objShell = CreateObject("WScript.Shell")

Set colFiles = objFolder.Files
For Each objFile in colFiles
	'Wscript.Echo objFile.Name
	objExtension = lcase(objFile)
	'Wscript.Echo objExtension
	'Wscript.Echo right(objExtension, 3)
	'Check if the file is an archive
	If right(objExtension, 3) = "zip" or right(objExtension, 3) = "cbz" _
	or right(objExtension, 3) = "cb7" or right(objExtension, 3) = "7z" _
	or right(objExtension, 3) = "lzh" or right(objExtension, 3) = "rar" _
	or right(objExtension, 3) = "cbr" or right(objExtension, 3) = "tar" _
	or right(objExtension, 3) = "cbt" Then
		'Dont want to redo work so if the cover exists don't make it again
		If Not objFSO.FileExists(objFile & ".jpg") and _
		Not objFSO.FileExists(objFile & ".gif") and _
		Not objFSO.FileExists(objFile & ".png") and _
		Not objFSO.FileExists(objFile & ".tif") Then
			'If the script broke before, dont try to create the temp folder again
			If Not objFSO.FolderExists(sTempPath) Then
				objFSO.CreateFolder(sTempPath)
			End If
			'Wscript.Echo objFile
			'Extract the folder and then list its contents in list.log
			'Dir will list files alphabetically
			objShell.Run "%comspec% /c" & sCurPath &  "\7z.exe e " & """" & objfile _ 
			& """ -o""" & sTempPath & """ -y", 7, true
			'I dont seem to be able to use the /u switch with comspec so I have to call
			'cmd.  This is only an issue if cmd.exe is not in the path
			objShell.Run "cmd /u /c dir /B " & sTempPath & "  > list.log", 7, true
			Set objLog = objFSO.GetFile("list.log")
			'OpenAsTextStream works with unicode unlike OpenTextFile
			Set sTextStream = objLog.OpenAsTextStream(ForReading, TristateTrue)
				Do While Not sTextStream.AtEndOfStream
					sText = sTextStream.ReadLine
					'Look for first file in log thats an image
					If right(lcase(sText),3) = "jpg" or right(lcase(sText),3) = "png" _
					or right(lcase(sText),3) = "gif" or right(lcase(sText),3) = "tif" Then
						sFirstImg = sTempPath & "\" & sText
						sText = objFile.Name & "." & right(sText,3)
						'WScript.Echo sFirstImg
						'MsgBox(objFolder & "\" & sText)
						'Was using this for my issues with unicode but it seems like a
						'good way to keep the script from breaking
						If objFSO.FileExists (sFirstImg) then
							objFSO.CopyFile sFirstImg, objFolder & "\" & sText, true
						Else
							'WScript.Echo sFirstImg
						End If
						Exit Do
					End If
				Loop
			sTextStream.Close
			'So I can check the log and temp folder before its deleted
			'msgBox("Wait here")
			'Was having problems with overwriting and it cleans up everything in the end
			objFSO.DeleteFile(sCurPath & "/" & "list.log")
			objFSO.DeleteFolder sTempPath, 1
		End If
	End If
Next

WScript.Echo "Script finished"
'Good Bye
WScript.Quit

' Using the shell's BrowseForFolder method to
' return the full path to the selected object
' title = Text shown in the dialog box
' flag = One of the values for controlling the 
'		BrowseForFolder behavior
' dir = Preselected directory (can be "")
Function BrowseForFolder(title, flag, dir)
	On Error Resume Next

	Dim oShell, oItem, tmp

	' Create WshShell object.
	Set oShell = WScript.CreateObject("Shell.Application")

	' Invoke Browse For Folder dialog box.
	Set oItem = oShell.BrowseForFolder(&H0, title, flag, dir)
	If Err.Number <> 0 Then
		If Err.Number = 5 Then
			BrowseForFolder= "-5"
			Err.Clear
			Set oShell = Nothing
			Set oItem = Nothing
			Exit Function
		End If
	End If

	' Now we try to retrieve the full path.
	BrowseForFolder = oItem.ParentFolder.ParseName(oItem.Title).Path

	' Handling: Cancel button and selecting a drive
	If Err<> 0 Then
		If Err.Number = 424 Then		   ' Handle Cancel button.
			BrowseForFolder = "-1"
		Else
			Err.Clear
			' Handle situation in which user selects a drive.
			' Extract drive letter from the title--first search
			' for a colon (:).
			tmp = InStr(1, oItem.Title, ":")
			If tmp > 0 Then		   ' A : is found; use two 
									  ' characters and add \.
				BrowseForFolder = Mid(oItem.Title, (tmp - 1), 2) & "\"
			End If
		End If
	End If

	Set oShell = Nothing
	Set oItem = Nothing
	On Error GoTo 0
End Function

'*** End

[ChronoStriker1]

Final edit, apparently in my over 2,000 manga, one had the images files hidden. There is no dir command that can show all files apparently so thats a bug that will stay.

[Edit] Ignore that Im an idiot, also NOW files are alphabetical so I should get the cover [/Edit]

'Script to get covers from comic archives
'by ChronoStriker1
'Feel free to use or modify for your own uses
'Requires 7zip, specifically 7z.exe in the dir its running from
'If you modify it in any usefull way please let me know
'Hell, if you find it usefull let me know
'Send an email to [email protected]

Option Explicit

' Flags for the options parameter
Const BIF_returnonlyfsdirs   = &H0001
Const BIF_dontgobelowdomain  = &H0002
Const BIF_statustext		 = &H0004
Const BIF_returnfsancestors  = &H0008
Const BIF_editbox			= &H0010
Const BIF_validate		   = &H0020
Const BIF_browseforcomputer  = &H1000
Const BIF_browseforprinter   = &H2000
Const BIF_browseincludefiles = &H4000
Const OverwriteExisting = True
Const ForReading = 1
Const TristateTrue = -1


Dim folder, objFSO, objFolder, colFiles, objFile, objExtension, objShell, objLog
Dim sText, sCurPath, sTempPath, sFirstImg, sTextStream

sCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
sTempPath = sCurPath & "\temp"
'WScript.Echo sTempPath

folder = BrowseForFolder("Select a folder to get covers from", BIF_returnonlyfsdirs, "")
If folder = "-5" Then 
	WScript.Echo "Not possible to select files in root folder"
	WScript.Quit
Else
	If folder = "-1" Then 
		WScript.Echo "No object selected; Cancel clicked"
		WScript.Quit
	Else
		'Folder path from browsforfolder
		'WScript.Echo "Object: ", folder
	End If
End If 

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(folder)

Set objShell = CreateObject("WScript.Shell")

Set colFiles = objFolder.Files
For Each objFile in colFiles
	'Wscript.Echo objFile.Name
	objExtension = lcase(objFile)
	'Wscript.Echo objExtension
	'Wscript.Echo right(objExtension, 3)
	'Check if the file is an archive
	If right(objExtension, 3) = "zip" or right(objExtension, 3) = "cbz" _
	or right(objExtension, 3) = "cb7" or right(objExtension, 3) = "7z" _
	or right(objExtension, 3) = "lzh" or right(objExtension, 3) = "rar" _
	or right(objExtension, 3) = "cbr" or right(objExtension, 3) = "tar" _
	or right(objExtension, 3) = "cbt" Then
		'Dont want to redo work so if the cover exists don't make it again
		If Not objFSO.FileExists(objFile & ".jpg") and _
		Not objFSO.FileExists(objFile & ".gif") and _
		Not objFSO.FileExists(objFile & ".png") and _
		Not objFSO.FileExists(objFile & ".tif") Then
			'If the script broke before, dont try to create the temp folder again
			If Not objFSO.FolderExists(sTempPath) Then
				objFSO.CreateFolder(sTempPath)
			End If
			'Wscript.Echo objFile
			'Extract the folder and then list its contents in list.log
			'Dir will list files alphabetically
			objShell.Run "%comspec% /c" & sCurPath &  "\7z.exe e " & """" & objfile _ 
			& """ -o""" & sTempPath & """ -y", 7, true
			'I dont seem to be able to use the /u switch with comspec so I have to call
			'cmd.  This is only an issue if cmd.exe is not in the path
			objShell.Run "cmd /u /c dir /b /a /on " & sTempPath & "  > list.log", 7, true
			Set objLog = objFSO.GetFile("list.log")
			'OpenAsTextStream works with unicode unlike OpenTextFile
			Set sTextStream = objLog.OpenAsTextStream(ForReading, TristateTrue)
				Do While Not sTextStream.AtEndOfStream
					sText = sTextStream.ReadLine
					'Look for first file in log thats an image
					If right(lcase(sText),3) = "jpg" or right(lcase(sText),3) = "png" _
					or right(lcase(sText),3) = "gif" or right(lcase(sText),3) = "tif" Then
						sFirstImg = sTempPath & "\" & sText
						sText = objFile.Name & "." & right(sText,3)
						'WScript.Echo sFirstImg
						'MsgBox(objFolder & "\" & sText)
						'Was using this for my issues with unicode but it seems like a
						'good way to keep the script from breaking
						If objFSO.FileExists (sFirstImg) then
							objFSO.CopyFile sFirstImg, objFolder & "\" & sText, true
						Else
							'WScript.Echo sFirstImg
						End If
						Exit Do
					End If
				Loop
			sTextStream.Close
			'So I can check the log and temp folder before its deleted
			'msgBox("Wait here")
			'Was having problems with overwriting and it cleans up everything in the end
			objFSO.DeleteFile(sCurPath & "/" & "list.log")
			objFSO.DeleteFolder sTempPath, 1
		End If
	End If
Next

WScript.Echo "Script finished"
'Good Bye
WScript.Quit

' Using the shell's BrowseForFolder method to
' return the full path to the selected object
' title = Text shown in the dialog box
' flag = One of the values for controlling the 
'		BrowseForFolder behavior
' dir = Preselected directory (can be "")
Function BrowseForFolder(title, flag, dir)
	On Error Resume Next

	Dim oShell, oItem, tmp

	' Create WshShell object.
	Set oShell = WScript.CreateObject("Shell.Application")

	' Invoke Browse For Folder dialog box.
	Set oItem = oShell.BrowseForFolder(&H0, title, flag, dir)
	If Err.Number <> 0 Then
		If Err.Number = 5 Then
			BrowseForFolder= "-5"
			Err.Clear
			Set oShell = Nothing
			Set oItem = Nothing
			Exit Function
		End If
	End If

	' Now we try to retrieve the full path.
	BrowseForFolder = oItem.ParentFolder.ParseName(oItem.Title).Path

	' Handling: Cancel button and selecting a drive
	If Err<> 0 Then
		If Err.Number = 424 Then		   ' Handle Cancel button.
			BrowseForFolder = "-1"
		Else
			Err.Clear
			' Handle situation in which user selects a drive.
			' Extract drive letter from the title--first search
			' for a colon (:).
			tmp = InStr(1, oItem.Title, ":")
			If tmp > 0 Then		   ' A : is found; use two 
									  ' characters and add \.
				BrowseForFolder = Mid(oItem.Title, (tmp - 1), 2) & "\"
			End If
		End If
	End If

	Set oShell = Nothing
	Set oItem = Nothing
	On Error GoTo 0
End Function

'*** End

Edited November 24, 2009 by ChronoStriker1