• 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

    • Anthropic pulls Fable 5 and Mythos 5 after US export control order

      By JayZJay · Posted

      I totally disagree. Very little good comes out of governments all around the world manipulating everything they can and usually the people are not the benefactors. What you say about being restricted and expensive sounds almost like the arguments against firearms and why banning them will protect people as if making something illegal somehow will prevent the criminals from having and using them. AI being far less mainstream could simply mean the average person will not benefit, but "big brother" and the corporations will benefit, which is almost for sure NOT a good thing.
    • Microsoft making much needed change to Windows 11, 10 Patch Tuesday security updates

      By lonegull · Posted

      I do apologize to the author Mr. Sen for my rude comment, questioning his knowledge of the subject. It is I whom lacked knowledge of the subject. Sorry!
    • USB Port Optimization for best locations for devices

      By bikeman25 · Posted

      Hello All Have a MSI Pro B650 VC Wifi Rev 1.0 motherboard Ryzen 7 7700X Radeon 7800XT OC 16GB 32GB Teamgroup DDR 5 5600mhz Samsung 990 Pro 1TB Boot NVMe Samsung 990 Pro 2TB Game NVMe Lian Li Lancool Black ARGB 216 Case Seasonic Focus GX 750 Watt Power supply   Wondering today what is best spot to plug in the following items on system for performance and not bottle neck anything if i can help it Creative Pebble Pro USB C or A Speakers, ((Powered by External USB C to C PD Adapter)  Logitech G513 USB Gaming Keyboard Logitech G502X Wired Gaming Mouse Cyberpower UPS USB Cable for UPS Power Management/System shutdown External drives connected occasionally are as follows---WD My Book 8TB (primary backup drive)   Seagate 8TB in External USB 3.0 Enclosure,  Seagate Portable 1TB USB 3.0 drive,   WD My Passport (Blue) 2TB, and WD My Passport (Red) 2TB,    WD Elements 500GB USB 2.0 External (Oldest one, Christmas 2003)       **Do have a 7 Port Powered  USB Hub as well, but when i use that--that leaves only the USB Flash spot for something to directly connect to system if needed.    Rear USB C 2x2 unused right now as moved the Creative speakers off it to USB A port next to it, with a USB C to A Cable, as figured speakers didn't near audio from USB C port and tie up the high speed port**   Front Ports trying to limit use of, so i don't have Front I/O port go bad again, already had it replaced once by Lian Li support all the way from Taiwan over night ((Do get extra nervous at times on things,  so i might just be extra nervous for nothing lol))
    • EA launches in-game advertising platform for brands to "connect with audiences"

      By RejZoR · Posted

      "connect with audiences" is the most obvious corporate speak you can think of. I only bought Need for Speed from EA because it was the only racing game with cops in existence and I dig that. Now that they killed off NFS franchise, I have nothing to spend money on. EA is officially dead for me, just like Ubisoft which I've been boycotting for some 20 years now...
    • Politically funny images of the World

      By +primortal · Posted

  • 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
      497
    2. 2
      +Edouard
      202
    3. 3
      PsYcHoKiLLa
      127
    4. 4
      Steven P.
      82
    5. 5
      ATLien_0
      77
    Show More

  • Tell a friend

    Love Neowin? Tell a friend!