• 0

[VBScript] Need unicode compatibility

Asked by ChronoStriker1,

 Share

Question

Community Regular

ChronoStriker1

Posted
Posted

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.

Link to comment
https://www.neowin.net/forum/topic/848016-vbscript-need-unicode-compatibility/
Share on other sites

3 answers to this question

Recommended Posts

  • 0
Community Regular

ChronoStriker1

Posted
  • Author
Posted (edited)

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 by ChronoStriker1
  • 0
Community Regular

ChronoStriker1

Posted
  • Author
Posted

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

  • 0
Community Regular

ChronoStriker1

Posted
  • Author
Posted (edited)

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 by ChronoStriker1
This topic is now closed to further replies.
 Share
Go to question listing

  • Recently Browsing   0 members

    • No registered users viewing this page.

  • Posts

    • Microsoft releases major feature updates for stock Windows 11 apps

      By PurSpyk · Posted

      Anyway to download these versions without being on the Experimental builds?
    • Microsoft about to radically change how often your Edge browser updates

      By testman · Posted

      Nothing is stopping you from continuing with your testing cadence. If updates are released every 2 weeks instead of 4, and you test once every 4 weeks, the exact same amount of patches will still be available for you in those 4 weeks. For example: Before 4th week - patch 1, 2, 3, 4 After 2nd week - patch 1 and 2 4th week - patch 3 and 4 Still the same amount after 4.
    • Microsoft about to radically change how often your Edge browser updates

      By testman · Posted

      Everyone else has said it. I'm gonna say it - you don't know what you're talking about. I do. I have two laptops. One work, one personal. I have access to two more laptops - both personal. At home I manually update my personal laptop when I see on Neowin that there is an update - I carry on and only apply the updates when I am ready. My work one only updates when my workplace decides to send it - I carry on and only apply the updates (when they actually arrive, which is usually days after the release) when I switch off the laptop at the end of the day as usual. The two other personal laptops only get updated when I get to it which is rarely - the people who own them carry on using them until I get to it and update them. All of the browsers on all laptops are configured to restore the tabs when launched. Google and Microsoft have changed from 6 weeks to 4, and it looks like it's going to move to 2. None of these changes affect how any of these browsers on the laptops are used. Not one jot. My advice to you is stop panicking whenever you see an update. Just carry on with what you're doing. This even benefits you in a way - from your comment you sound like you don't like the changes or the frivolous new features - great - then carry on as before!
    • Lethal fake phone chargers are still being sold on Amazon and eBay, UK watchdog warns

      By Brian Miller · Posted

      AMAZON needs to take total accountability for this.
    • Windows Server gets DNS over HTTPS (DoH) support

      By binaryzero · Posted

      Server Summit had a heap of announcements, ADCS changes are baller.

  • Recent Achievements

    • Week One Done
      Jeroen Wilms earned a badge
      Week One Done
    • Week One Done
      rolfus earned a badge
      Week One Done
    • One Month Later
      Leroy Jethro Gibbs earned a badge
      One Month Later
    • Conversation Starter
      flexorcist earned a badge
      Conversation Starter
    • One Month Later
      AndreaB earned a badge
      One Month Later

  • Popular Contributors

    1. 1
      +primortal
      509
    2. 2
      +Edouard
      198
    3. 3
      PsYcHoKiLLa
      138
    4. 4
      ATLien_0
      90
    5. 5
      Steven P.
      80
    Show More

  • Tell a friend

    Love Neowin? Tell a friend!