Search this blog ...

Friday, August 31, 2012

Windows 7 Replacement for UserAccounts.CommonDialog in VBScript

After 6 years of mostly trouble-free development/engineering, I finally retired my Windows XP-based Dell Latitude D620 from active work duty.  I had been holding out for a business laptop with USB 3.0 to become available on the internal procurement site, and were finally able to obtain a Lenovo X230 with an Ivy Bridge i5-3320M processor.  (Un)fortunately this new machine is running Windows 7 x64, and for that matter a bastardized version full of all the resource hungry corporate mandated bloat.  This is the first time I have seen/used Windows 7 (having managed to also completely avoid Vista). The first thing I find myself doing is trying to make Windows 7 feel and behave like Windows XP again.  After installing classic shell to get the old start button functionality back (http://classicshell.sourceforge.net/) and turning off all of the visual effects (aka – ‘Adjust for best performance’ setting), my desktop is starting to resemble and feel like the ugly but reliable XP again.  Now I’m slowly working through my kit bag of productivity scripts that I created for XP and trying to get these to function in Windows 7.

One of the more frequent scripts I leverage is a simple VBScript for upload and download of a file by invoking the command-line FTP utility shipped with Windows.  See the following article I wrote for the full original XP supported source code: http://todayguesswhat.blogspot.com.au/2010/06/vbscript-ftp-upload-sample-leverages.html

I found out that the UserAccounts.CommonDialog class/control is not available in Windows 7. I leveraged this control to allow the user to select a file for upload.  Original VBScript code shown below:

Function ChooseFile(initialDir)
  Set cd = CreateObject("UserAccounts.CommonDialog")

  cd.InitialDir = initialDir
  cd.Filter = "ZIP files|*.zip|Text Documents|*.txt|Shell Scripts|*.*sh|All Files|*.*"
  ' filter index 4 would show all files by default
  ' filter index 1 would should zip files by default
  cd.FilterIndex = 1
  If cd.ShowOpen = True Then
    ChooseFile = cd.FileName
  Else
    ChooseFile = ""
  End If
  Set cd = Nothing
End Function

For Windows 7, I’ve kludged together code to replace the above method using techniques/articles/suggestions borrowed from multiple parties.  If there is a cleaner mechanism to navigate and select a file using VBScript in Windows 7, please let me know :)

The code I developed/hacked-together creates a temporary powershell script that spawns System.Windows.Forms OpenFileDialog, and then writes the chosen file out to a temporary output text file. The VBScript then reads in the value from the output text file and returns that in the function.  Code is as follows:

Function ChooseFile (ByVal initialDir)

  Set shell = CreateObject("WScript.Shell")

  Set fso = CreateObject("Scripting.FileSystemObject")

  tempDir = shell.ExpandEnvironmentStrings("%TEMP%")

  tempFile = tempDir & "\" & fso.GetTempName

  ' temporary powershell script file to be invoked
  powershellFile = tempFile & ".ps1"

  ' temporary file to store standard output from command
  powershellOutputFile = tempFile & ".txt"

  'input script
  psScript = psScript & "[System.Reflection.Assembly]::LoadWithPartialName(""System.windows.forms"") | Out-Null" & vbCRLF
  psScript = psScript & "$dlg = New-Object System.Windows.Forms.OpenFileDialog" & vbCRLF
  psScript = psScript & "$dlg.initialDirectory = """ &initialDir & """" & vbCRLF
  psScript = psScript & "$dlg.filter = ""ZIP files|*.zip|Text Documents|*.txt|Shell Scripts|*.*sh|All Files|*.*""" & vbCRLF
  ' filter index 4 would show all files by default
  ' filter index 1 would should zip files by default
  psScript = psScript & "$dlg.FilterIndex = 4" & vbCRLF
  psScript = psScript & "$dlg.Title = ""Select a file to upload""" & vbCRLF
  psScript = psScript & "$dlg.ShowHelp = $True" & vbCRLF
  psScript = psScript & "$dlg.ShowDialog() | Out-Null" & vbCRLF
  psScript = psScript & "Set-Content """ &powershellOutputFile & """ $dlg.FileName" & vbCRLF
  MsgBox psScript
 
  Set textFile = fso.CreateTextFile(powershellFile, True)
  textFile.WriteLine(psScript)
  textFile.Close
  Set textFile = Nothing

  ' objShell.Run (strCommand, [intWindowStyle], [bWaitOnReturn])
  ' 0 Hide the window and activate another window.
  ' bWaitOnReturn set to TRUE - indicating script should wait for the program
  ' to finish executing before continuing to the next statement

  Dim appCmd
  appCmd = "powershell -ExecutionPolicy unrestricted &'" & powershellFile & "'"
  MsgBox appCmd
  shell.Run appCmd, 0, TRUE

  ' open file for reading, do not create if missing, using system default format
  Set textFile = fso.OpenTextFile(powershellOutputFile, 1, 0, -2)
  ChooseFile = textFile.ReadLine
  textFile.Close
  Set textFile = Nothing
  fso.DeleteFile(powershellFile)
  fso.DeleteFile(powershellOutputFile)

End Function

UPDATE – May 2013

Some commenters have suggested leveraging BrowseForFolder.  At least for me, this produces strange behaviour on Windows 7 and may return -2147467259 (80004005) error code for certain file types (for example txt files) - but not others (e.g. zip).  I would NOT recommend it.

Here is a a new and improved version which is must faster than above and should be backward compatible with XP:-

Set shell = CreateObject( "WScript.Shell" )
defaultLocalDir = shell.ExpandEnvironmentStrings("%USERPROFILE%") & "\Desktop"
Set shell = Nothing

file = ChooseFile(defaultLocalDir)
MsgBox file

Function ChooseFile (ByVal initialDir)
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")

    Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
    Dim winVersion

    ' This collection should contain just the one item
    For Each objItem in colItems
        'Caption e.g. Microsoft Windows 7 Professional
        'Name e.g. Microsoft Windows 7 Professional |C:\windows|...
        'OSType e.g. 18 / OSArchitecture e.g 64-bit
        'Version e.g 6.1.7601 / BuildNumber e.g 7601
        winVersion = CInt(Left(objItem.version, 1))
    Next
    Set objWMIService = Nothing
    Set colItems = Nothing

    If (winVersion <= 5) Then
        ' Then we are running XP and can use the original mechanism
        Set cd = CreateObject("UserAccounts.CommonDialog")
        cd.InitialDir = initialDir
        cd.Filter = "ZIP files|*.zip|Text Documents|*.txt|Shell Scripts|*.*sh|All Files|*.*"
        ' filter index 4 would show all files by default
        ' filter index 1 would show zip files by default
        cd.FilterIndex = 1
        If cd.ShowOpen = True Then
            ChooseFile = cd.FileName
        Else
            ChooseFile = ""
        End If
        Set cd = Nothing    

    Else
        ' We are running Windows 7 or later
        Set shell = CreateObject( "WScript.Shell" )
        Set ex = shell.Exec( "mshta.exe ""about: <input type=file id=X><script>X.click();new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).WriteLine(X.value);close();resizeTo(0,0);</script>""" )
        ChooseFile = Replace( ex.StdOut.ReadAll, vbCRLF, "" )

        Set ex = Nothing
        Set shell = Nothing
    End If
End Function   

9 comments:

  1. I have an alternative which I have pieced together from my "goolging"

    strComputer = "."
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

    Set colItems = objWMIService.ExecQuery _
    ("Select * from Win32_OperatingSystem")

    For Each objItem in colItems

    intVersion = CInt(Left(objItem.version, 1))

    If (intVersion <= 5) Then

    Set objDialog = CreateObject("UserAccounts.CommonDialog")

    objDialog.Filter = "All Files|*.*"
    objDialog.InitialDir = "C:\Scripts\Data"
    intResult = objDialog.ShowOpen

    If (intResult = 0) Then

    Wscript.Echo "You have not selected the right response. Script Is Closing Down"
    Wscript.Quit

    Else

    Wscript.Echo objDialog.FileName

    End If

    strPathToExileFile = objDialog.FileName
    Exit For

    Else
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")
    Set objFile = objShell.BrowseForFolder(0, "Choose a file:", &H4000)

    strPathToExileFile = objFile.self.Path

    If Not(objFSO.FileExists(strPathToExileFile)) Then

    Wscript.Echo "You have not selected the right response. Script Is Closing Down"

    Set objFile = Nothing
    Set objFilePath = Nothing
    Set objShell = Nothing
    Set objFSO = Nothing

    Wscript.Quit
    End If

    Set objFile = Nothing
    Set objShell = Nothing
    Set objFSO = Nothing

    Exit For
    End If


    Next


    Set objWMIService = Nothing
    Set colItems = Nothing


    Set objExcel = CreateObject("Excel.Application")
    Set objWorkbook = objExcel.Workbooks.Open(strPathToExileFile)
    objExcel.Visible = True

    ReplyDelete
  2. Ossie, your answer was amazing!
    I did not want to use PowerShell because I need to redistribute it on my code and it is not my intention.

    Just a fix to your code:
    When user press Cancel, an error is thrown because no file was selected.
    We need to add an workaround to check if some file was selected and, if not, closes script.
    Please note the function IsValue() that was added to the code.

    strComputer = "."
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

    Set colItems = objWMIService.ExecQuery _
    ("Select * from Win32_OperatingSystem")

    For Each objItem in colItems

    intVersion = CInt(Left(objItem.version, 1))

    If (intVersion <= 5) Then

    Set objDialog = CreateObject("UserAccounts.CommonDialog")

    objDialog.Filter = "All Files|*.*"
    objDialog.InitialDir = "C:\Scripts\Data"
    intResult = objDialog.ShowOpen

    If (intResult = 0) Then

    Wscript.Echo "You have not selected the right response. Script Is Closing Down"
    Wscript.Quit

    Else

    Wscript.Echo objDialog.FileName

    End If

    strPathToExileFile = objDialog.FileName
    Exit For

    Else
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")
    Set objFile = objShell.BrowseForFolder(0, "Choose a file:", &H4000)

    if IsValue(objFile)
    strPathToExileFile = objFile.self.Path

    If Not(objFSO.FileExists(strPathToExileFile)) Then

    Wscript.Echo "You have not selected the right response. Script Is Closing Down"

    Set objFile = Nothing
    Set objFilePath = Nothing
    Set objShell = Nothing
    Set objFSO = Nothing

    Wscript.Quit
    End If
    Else
    ' User pressed Cancel
    WScript.Quit
    End if

    Set objFile = Nothing
    Set objShell = Nothing
    Set objFSO = Nothing

    Exit For
    End If


    Next


    Set objWMIService = Nothing
    Set colItems = Nothing


    Set objExcel = CreateObject("Excel.Application")
    Set objWorkbook = objExcel.Workbooks.Open(strPathToExileFile)
    objExcel.Visible = True

    Function IsValue(obj)
    ' Check whether a value has been returned.
    Dim tmp
    On Error Resume Next
    tmp = " " & obj
    If Err <> 0 Then
    IsValue = False
    Else
    IsValue = True
    End If
    On Error GoTo 0
    End Function

    If no file was selected (Cancel pressed), script closes automatically without error messages.

    ReplyDelete
  3. Ossie, I agree---thanks for this. It's just what I needed.
    Eduardo, thanks for the updated code...works great.

    Umm...except for one small thing. A "Then" statement was left out.

    .
    .
    .
    .
    Set objShell = CreateObject("Shell.Application")
    Set objFile = objShell.BrowseForFolder(0, "Choose a file:", &H4000)

    If IsValue(objFile) Then '<<-------------This "Then" was omitted.
    strPathToExileFile = objFile.self.Path

    If Not(objFSO.FileExists(strPathToExileFile)) Then

    WScript.Echo "You have not selected the right response. Script Is Closing Down"

    Set objFile = Nothing
    .
    .
    .
    .

    ReplyDelete
  4. I posted a replacement version today that leverages mshta.exe. It is much faster, however you cannot set a starting directory, nor choose file extension masks. Shell.Application.BrowseForFolder does not produce reliable results for me and will error out on certain file types.

    ReplyDelete
  5. hi..Im student from Informatics engineering, this article is very informative, thanks for sharing :)

    ReplyDelete
  6. I always get an "unspecified error: 80004005" when I try to run this.

    ReplyDelete
    Replies
    1. This is exactly the error code reported above that triggered 'UPDATE – May 2013'

      Delete
  7. On Win7 is there a way to limit the file types the dialog will display e.g. only .ini files?

    ReplyDelete