WScript/VBScript脚本全兼容打开文件选择对话框(VBS Open File Dialog)

!本文可能 超过1年没有更新,今后内容也许不会被维护或者支持,部分内容可能具有时效性,涉及技术细节或者软件使用方面,本人不保证相应的兼容和可操作性。

前面有一篇文章《WScript脚本打开文件夹选择对话框》向大家介绍如何通过VBS打开文件夹选择对话框,其中用到了Shell.Application,这个组件一般Windows系统都自带,所以在兼容方面不需要我们操心。打开/保存文件对话框我们可能在脚本编程中用得到,本来以为打开文件和打开文件夹一样简单,没想到费了一番周折。

起初使用了UserAccounts.CommonDialog组件,代码如下:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
' dir is the initial directory; if no directory is
' specified "Desktop" is used.
' filter is the file type filter; format "File type description|*.ext"
Function GetOpenFileName(dir, filter)
    Dim objDialog
    Set objDialog = WSH.CreateObject("UserAccounts.CommonDialog")
    If VarType(dir) <> vbString Or dir="" Then
        objDialog.InitialDir = _
            CreateObject( "WScript.Shell" ).SpecialFolders( "Desktop" )
    Else
        objDialog.InitialDir = dir
    End If
 
    If VarType(filter) <> vbString Or filter="" Then
        objDialog.Filter = "All files|*.*"
    Else
        objDialog.Filter = filter
    End If
 
    If objDialog.ShowOpen Then
        GetOpenFileName = objDialog.FileName
    Else
        GetOpenFileName = ""
    End If
    Set objDialog = Nothing
End Function
 
' Test
Dim strFileName
strFileName = GetOpenFileName("C:\","All files|*.*|Microsoft Word|*.doc")

测试的系统是Windows XP,很好很大众的系统,而且上述脚本也能够完美运行,当然如果没有接下来发生的事情,也不会有我这篇文章了,接下来我把包含这段代码的脚本提供给一位使用Windows 7系统的朋友,结果出错了:“ActiveX 部件不能创建对象:‘UserAccounts.CommonDialog’,代码:800A01AD,Microsoft VBScript 运行时错误”。

很明显Windows 7下不包含这个组件,进一步上网搜索得知,UserAccounts.CommonDialog竟然是XP Only的。针对于这个问题,很多朋友给出了解决方案,包括使用MSComDlg.CommonDialog,呵呵,这个可不是系统内置的,这个一般在安装有VB运行环境才会有,控件名称是MSCOMDLG32.OCX,而且我们必须调用regsvr32注册这个控件,我检查了一下,内置有这个控件的机器还真不多,所以这个方案和上面的UserAccounts.CommonDialog一样不是通用的解决办法。

写到这里,我想起了我以前一篇介绍VBA合并Word文件的文章,里面介绍了Word.Application内置的对话框调用。大家可以参考这篇文章介绍的办法,通过Word.Application对象也能打开一个文件对话框,这给我们又拓宽了解决思路,但是纠结的兼容问题始终不能放过我们,Word.Application组件需要安装Microsoft Office啊,虽说Office安装还是蛮普遍的,但是我们也不能假设人人都安装有微软牌的Office啊。

问题貌似陷入了僵局,直到看到了这篇文章《JScript on WSHでファイル選択ダイアログを表示する方法のまとめ》,呵呵,可惜是日文的,不过里面的程序代码还是能看得懂的,借助谷歌翻译,勉强看过文章,其使用了一个打开文件对话框的终极方案,那就是使用InternetExplorer.Application模拟input type=’file’这样上传文件对话框的HTML标记来实现打开文件对话框,借助了IE(Internet Explorer),IE这玩意基本上每台Windows系统都自带了,别说卸载了,据说IE是不能彻底卸载掉的。

好了,到这里我有了思路,可以先后尝试UserAccounts.CommonDialog、MSComDlg.CommonDialog、Word.Application、InternetExplorer.Application直到找到一个能够成功创建CreateObject并使用的对象为止,然后我们再针对特定对象编码。可能有人要问,为什么不直接用IE的InternetExplorer.Application,而要一个一个尝试呢?因为IE那个对话框太简陋了,而且可控制的选项很少(基本没有)。所以遵循优雅的降级策略,我们要从高级到低级尝试完成任务。好了,我把代码放出来供大家参考吧:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
'
' Description: VBScript/VBS open file dialog
'              Compatible with most Windows platforms
' Author: wangye  <pcn88 at hotmail dot com>
' Website: http://wangye.org
'
' dir is the initial directory; if no directory is
' specified "Desktop" is used.
' filter is the file type filter; format "File type description|*.ext"
'
Public Function GetOpenFileName(dir, filter)
    Const msoFileDialogFilePicker = 3
 
    If VarType(dir) <> vbString Or dir="" Then
        dir = CreateObject( "WScript.Shell" ).SpecialFolders( "Desktop" )
    End If
 
    If VarType(filter) <> vbString Or filter="" Then
        filter = "All files|*.*"
    End If
 
    Dim i,j, objDialog, TryObjectNames
    TryObjectNames = Array( _
        "UserAccounts.CommonDialog", _
        "MSComDlg.CommonDialog", _
        "MSComDlg.CommonDialog.1", _
        "Word.Application", _
        "SAFRCFileDlg.FileOpen", _
        "InternetExplorer.Application" _
        )
 
    On Error Resume Next
    Err.Clear
 
    For i=0 To UBound(TryObjectNames)
        Set objDialog = WSH.CreateObject(TryObjectNames(i))
        If Err.Number<>0 Then
        Err.Clear
        Else
        Exit For
        End If
    Next
 
    Select Case i
        Case 0,1,2
        ' 0. UserAccounts.CommonDialog XP Only.
        ' 1.2. MSComDlg.CommonDialog MSCOMDLG32.OCX must registered.
        If i=0 Then
            objDialog.InitialDir = dir
        Else
            objDialog.InitDir = dir
        End If
        objDialog.Filter = filter
        If objDialog.ShowOpen Then
            GetOpenFileName = objDialog.FileName
        End If
        Case 3
        ' 3. Word.Application Microsoft Office must installed.
        objDialog.Visible = False
        Dim objOpenDialog, filtersInArray
        filtersInArray = Split(filter, "|")
        Set objOpenDialog = _
            objDialog.Application.FileDialog( _
                msoFileDialogFilePicker)
            With objOpenDialog
            .Title = "Open File(s):"
            .AllowMultiSelect = False
            .InitialFileName = dir
            .Filters.Clear
            For j=0 To UBound(filtersInArray) Step 2
                .Filters.Add filtersInArray(j), _
                     filtersInArray(j+1), 1
            Next
            If .Show And .SelectedItems.Count>0 Then
                GetOpenFileName = .SelectedItems(1)
            End If
            End With
            objDialog.Visible = True
            objDialog.Quit
        Set objOpenDialog = Nothing
        Case 4
        ' 4. SAFRCFileDlg.FileOpen xp 2003 only
        ' See http://www.robvanderwoude.com/vbstech_ui_fileopen.php
        If objDialog.OpenFileOpenDlg Then
           GetOpenFileName = objDialog.FileName
        End If
        Case 5
        ' 5. InternetExplorer.Application IE must installed
        objDialog.Navigate "about:blank"
        Dim objBody, objFileDialog
        Set objBody = _
            objDialog.document.getElementsByTagName("body")(0)
        objBody.innerHTML = "<input type='file' id='fileDialog'>"
        while objDialog.Busy Or objDialog.ReadyState <> 4
            WScript.sleep 10
        Wend
        Set objFileDialog = objDialog.document.all.fileDialog
            objFileDialog.click
            GetOpenFileName = objFileDialog.value
            objDialog.Quit
        Set objFileDialog = Nothing
        Set objBody = Nothing
        Case Else
        ' Sorry I cannot do that!
    End Select
 
    Set objDialog = Nothing
End Function
 
' Test
Dim strFileName
strFileName = GetOpenFileName("C:\","All files|*.*|Microsoft Word|*.doc")

其实UserAccounts.CommonDialog、MSComDlg.CommonDialog在方法和成员上还是比较类似的,在这里我对一处不同点InitialDir和InitDir作了判断处理,InitialDir是UserAccounts.CommonDialog所有的,InitDir是MSComDlg.CommonDialog所有的,好了,上面的代码基本上通吃所有Windows系统了,代码我放在github的gist上了,欢迎交流。

2012年2月28日更新

新增加SAFRCFileDlg.FileOpen组件办法,原文代码已经修改。

2012年4月19日更新

感谢jerry提出这个Bug,由于微软出于安全性考虑,于是IE8/IE9及以上版本的浏览器type=file文件上传控件,直接获取将只能得到类似C:\fakepath\文件全名的虚假路径,我们可以通过设置IE来解决这个问题。
工具 – Internet选项 – 安全 – 自定义级别 – 找到“其他”中的“将本地文件上载至服务器时包含本地目录路径”,选中“启用”即可。

将本地文件上载至服务器时包含本地目录路径

当然我们可不期望用户能够自己去修改这个配置,接下来谈下如何绕过这个安全限制,参考了网上的关于JavaScript的实现,多是通过如下代码来实现的:

obj.select();
var realfile = document.selection.createRange().text;

遗憾的是针对于调用了InternetExplorer.Application的VBScript,同样的解决方案将起不到任何作用:

99
100
101
102
' GetOpenFileName = objFileDialog.value
  objFileDialog.Select
  GetOpenFileName = _
    objFileDialog.document.selection.createRange.text

既然这个办法行不通那只有另寻方案了,微软说明MSHTA可以不受这个安全限制,事实上我还真找到取道MSHTA绕过这个安全限制的实现办法,由mlhaufe提供:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
' Bypasses c:\fakepath\file.txt problem
' http://pastebin.com/txVgnLBV
Function BrowseForFile()
    Dim shell : Set shell = CreateObject("WScript.Shell")
    Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
    Dim tempFolder : Set tempFolder = fso.GetSpecialFolder(2)
    Dim tempName : tempName = fso.GetTempName()
    Dim tempFile : Set tempFile = tempFolder.CreateTextFile(tempName & ".hta")
    tempFile.Write _
        "<html>" & _
        "  <head>" & _
        "    <title>Browse</title>" & _
        "  </head>" & _
        "  <body>" & _
        "    <input type='file' id='f'>" & _
        "    <script type='text/javascript'>" & _
        "      var f = document.getElementById('f');" & _
        "      f.click();" & _
        "      var shell = new ActiveXObject('WScript.Shell');" & _
        "      shell.RegWrite('HKEY_CURRENT_USER\\Volatile Environment\\MsgResp', f.value);" & _
        "      window.close();" & _
        "    </script>" & _
        "  </body>" & _
        "</html>"
    tempFile.Close
 
    shell.Run tempFolder & "\" & tempName & ".hta", 1, True
 
    BrowseForFile = shell.RegRead("HKEY_CURRENT_USER\Volatile Environment\MsgResp")
    shell.RegDelete "HKEY_CURRENT_USER\Volatile Environment\MsgResp"
End Function
 
MsgBox BrowseForFile

实现的思路很简单,就是通过创建包含上传框的MSHTA文件(*.hta),通过运行这个hta网页程序,将上传任务交给它,而hta不受这个路径安全限制,那么就可以获取正确的路径,再将这个路径临时写入注册表,再通过读取注册表键值获得刚刚写入的数据,最后清理注册表。

这个方法也算有借鉴意义,唯一感到有些缺陷的是,假如有多个VBS实例同时访问这个注册表键值,那么势必会造成冲突,解决的办法可以不用上面代码的MsgResp,采用随机键,用完后立即删除,旧问题解决了,新问题也产生了,就是如果VBS非正常终止,那么这个随机生成的临时键值将不会被删除,这样可能会造成注册表垃圾键值越来越多,而变得臃肿。

我想借助临时文件,将路径写入临时文件里,然后读取,完成后及时清除临时文件,即使VBScript意外终止而没有清除临时文件,随着时间的推移,这些临时文件依旧会被系统自动删除,按照这个思路,代码修改如下:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
' Bypasses c:\fakepath\file.txt problem
Function BrowseForFile()
    Dim shell : Set shell = CreateObject("WScript.Shell")
    Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
    Dim tempFolder : Set tempFolder = fso.GetSpecialFolder(2)
    Dim tempName : tempName = fso.GetTempName()
    Dim tempFile : Set tempFile = tempFolder.CreateTextFile(tempName & ".hta")
    Dim tempBaseName
    tempBaseName = tempFolder & "\" & tempName
    tempFile.Write _
        "<html>" & _
        "  <head>" & _
        "    <title>Browse</title>" & _
        "  </head>" & _
        "  <body>" & _
        "    <input type='file' id='f'>" & _
        "    <script type='text/javascript'>" & _
        "      var f = document.getElementById('f');" & _
        "      f.click();" & _
        "      var fso = new ActiveXObject('Scripting.FileSystemObject');" & _
        "      var file = fso.OpenTextFile('" & _
                  Replace(tempBaseName,"\", "\\") & ".txt" & "', 2, true);" & _
        "      file.Write(f.value);" & _
        "      file.Close();" & _
        "      window.close();" & _
        "    </script>" & _
        "  </body>" & _
        "</html>"
    tempFile.Close
 
    shell.Run tempBaseName & ".hta", 1, True
    Set tempFile = fso.OpenTextFile(tempBaseName & ".txt", 1)
    BrowseForFile = tempFile.ReadLine
    tempFile.Close
    fso.DeleteFile tempBaseName & ".hta"
    fso.DeleteFile tempBaseName & ".txt"
End Function
 
MsgBox BrowseForFile

接下来我想考虑将上面的代码加入我的GetOpenFileName函数中,哎,时间不早了,明天再说吧。

2012年4月20日更新

好,下面我把昨天的代码整合进我的GetOpenFileName函数中,基本思路是这样的,先判断IE版本,如果大于IE7,那么就直接采用HTA方式绕过fakepath,据我掌握的资料来看fakepath安全限制只存在于IE8及更高版本的IE中,IE7尚未测试,不过即使IE7也有这个问题,改起来也容易,说到判断版本,对于网页前端来说最简单不过了,直接查找User-Agent Strings特征值,通过形如下面的js脚本即可:

alert(navigator.userAgent)

很遗憾,我查找了相关资料结果在InternetExplorer.Application组件中未能找到这个方法,看来只有绕道了,这里先提供一个MSDN关于User-Agent Strings的说明文章,该文章给出了注册表查找UA的办法,我想何不直接通过注册表来确定IE版本呢?

注册表查找IE版本也很容易,直接定位到HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer下的Version键值就可以了。

注册表查找IE版本

最终的代码如下:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
'
' Description: VBScript/VBS open file dialog
'              Compatible with most Windows platforms
' Author: wangye  <pcn88 at hotmail dot com>
' Website: http://wangye.org
'
' dir is the initial directory; if no directory is
' specified "Desktop" is used.
' filter is the file type filter; format "File type description|*.ext"
'
Public Function GetOpenFileName(dir, filter)
    Const msoFileDialogFilePicker = 3
 
    If VarType(dir) <> vbString Or dir="" Then
        dir = CreateObject( "WScript.Shell" ).SpecialFolders( "Desktop" )
    End If
 
    If VarType(filter) <> vbString Or filter="" Then
        filter = "All files|*.*"
    End If
 
    Dim i,j, objDialog, TryObjectNames
    TryObjectNames = Array( _
        "UserAccounts.CommonDialog", _
        "MSComDlg.CommonDialog", _
        "MSComDlg.CommonDialog.1", _
        "Word.Application", _
        "SAFRCFileDlg.FileOpen", _
        "InternetExplorer.Application" _
        )
 
    On Error Resume Next
    Err.Clear
 
    For i=0 To UBound(TryObjectNames)
        Set objDialog = WSH.CreateObject(TryObjectNames(i))
        If Err.Number<>0 Then
        Err.Clear
        Else
        Exit For
        End If
    Next
 
    Select Case i
        Case 0,1,2
        ' 0. UserAccounts.CommonDialog XP Only.
        ' 1.2. MSComDlg.CommonDialog MSCOMDLG32.OCX must registered.
        If i=0 Then
            objDialog.InitialDir = dir
        Else
            objDialog.InitDir = dir
        End If
        objDialog.Filter = filter
        If objDialog.ShowOpen Then
            GetOpenFileName = objDialog.FileName
        End If
        Case 3
        ' 3. Word.Application Microsoft Office must installed.
        objDialog.Visible = False
        Dim objOpenDialog, filtersInArray
        filtersInArray = Split(filter, "|")
        Set objOpenDialog = _
            objDialog.Application.FileDialog( _
                msoFileDialogFilePicker)
            With objOpenDialog
            .Title = "Open File(s):"
            .AllowMultiSelect = False
            .InitialFileName = dir
            .Filters.Clear
            For j=0 To UBound(filtersInArray) Step 2
                .Filters.Add filtersInArray(j), _
                     filtersInArray(j+1), 1
            Next
            If .Show And .SelectedItems.Count>0 Then
                GetOpenFileName = .SelectedItems(1)
            End If
            End With
            objDialog.Visible = True
            objDialog.Quit
        Set objOpenDialog = Nothing
        Case 4
        ' 4. SAFRCFileDlg.FileOpen xp 2003 only
        ' See http://www.robvanderwoude.com/vbstech_ui_fileopen.php
        If objDialog.OpenFileOpenDlg Then
           GetOpenFileName = objDialog.FileName
        End If
        Case 5
 
        Dim IEVersion,IEMajorVersion, hasCompleted
        hasCompleted = False
        Dim shell
        Set shell = CreateObject("WScript.Shell")
        ' 下面获取IE版本
        IEVersion = shell.RegRead( _
            "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Version")
        If InStr(IEVersion,".")>0 Then
            ' 获取主版本号
            IEMajorVersion = CInt(Left(IEVersion, InStr(IEVersion,".")-1))
            If IEMajorVersion>7 Then
                ' 如果版本号大于7,也就是大于IE7,则采取MSHTA方案
                ' Bypasses c:\fakepath\file.txt problem
                ' http://pastebin.com/txVgnLBV
                Dim fso
                Set fso = CreateObject("Scripting.FileSystemObject")
 
                Dim tempFolder : Set tempFolder = fso.GetSpecialFolder(2)
                Dim tempName : tempName = fso.GetTempName()
                Dim tempFile : Set tempFile = tempFolder.CreateTextFile(tempName & ".hta")
                Dim tempBaseName
                tempBaseName = tempFolder & "\" & tempName
                tempFile.Write _
                    "<html>" & _
                    "  <head>" & _
                    "    <title>Browse</title>" & _
                    "  </head>" & _
                    "  <body>" & _
                    "    <input type='file' id='f'>" & _
                    "    <script type='text/javascript'>" & _
                    "      var f = document.getElementById('f');" & _
                    "      f.click();" & _
                    "      var fso = new ActiveXObject('Scripting.FileSystemObject');" & _
                    "      var file = fso.OpenTextFile('" & _
                              Replace(tempBaseName,"\", "\\") & ".txt" & "', 2, true);" & _
                    "      file.Write(f.value);" & _
                    "      file.Close();" & _
                    "      window.close();" & _
                    "    </script>" & _
                    "  </body>" & _
                    "</html>"
                tempFile.Close
                Set tempFile = Nothing
                Set tempFolder = Nothing
                shell.Run tempBaseName & ".hta", 1, True
                Set tempFile = fso.OpenTextFile(tempBaseName & ".txt", 1)
                GetOpenFileName = tempFile.ReadLine
                tempFile.Close
                fso.DeleteFile tempBaseName & ".hta"
                fso.DeleteFile tempBaseName & ".txt"
                Set tempFile = Nothing
                Set fso = Nothing
                hasCompleted = True ' 标记为已完成
            End If
        End If
        If Not hasCompleted Then
            ' 5. InternetExplorer.Application IE must installed
            objDialog.Navigate "about:blank"
            Dim objBody, objFileDialog
            Set objBody = _
                objDialog.document.getElementsByTagName("body")(0)
            objBody.innerHTML = "<input type='file' id='fileDialog'>"
            while objDialog.Busy Or objDialog.ReadyState <> 4
                WScript.sleep 10
            Wend
            Set objFileDialog = objDialog.document.all.fileDialog
                objFileDialog.click
                GetOpenFileName = objFileDialog.value
        End If
        objDialog.Quit
        Set objFileDialog = Nothing
        Set objBody = Nothing
        Set shell = Nothing
        Case Else
        ' Sorry I cannot do that!
    End Select
 
    Set objDialog = Nothing
End Function

呵呵,代码有些冗长,对于一个函数来说,本来想拆成Class的,不过想想也就算了,就是个简单的功能,没必要再New了。

2012年4月22日更新

COMDLG32.OCX下载地址COMDLG32.OCX下载 (299)

2012年4月29日更新

今天有网友提到了VBS Save File Dialog即保存文件对话框,非常抱歉的是,保存文件对话框的脚本不是很通用的,首先这些组件将壮烈牺牲:UserAccounts.CommonDialog、SAFRCFileDlg.FileOpen和InternetExplorer.Application,当然SAFRCFileDlg.FileOpen可以改成SAFRCFileDlg.FileSave,但是在XP下测试貌似有问题。最后压轴的InternetExplorer.Application据我了解,绕到IE的对话框只能选择文件,无法打开另存为文件对话框。

好吧,下面我们重整一下队伍,能够实现保存文件对话框的组件有:MSComDlg.CommonDialog、Word.Application和SAFRCFileDlg.FileSave,其中MSComDlg.CommonDialog需要注册组件COMDLG32.OCX,到最后还是要依靠Word.Application这个Office自带的组件,当然对于XP据说SAFRCFileDlg.FileSave也是可以用的。

这样的话,这个保存文件对话框的通用性就大打折扣了,建议有条件的还是注册COMDLG32.OCX来实现吧,当然如果你有好的办法可以说明,非常感谢。

下面提供测试用的代码:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
'
' Description: VBScript/VBS save file dialog
' 
' Author: wangye  <pcn88 at hotmail dot com>
' Website: http://wangye.org
'
' dir is the initial directory; if no directory is
' specified "Desktop" is used.
' filter is the file type filter; format "File type description|*.ext"
'
Public Function GetSaveFileName(dir, filter)
    Const msoFileDialogSaveAs = 2 
 
    If VarType(dir) <> vbString Or dir="" Then
        dir = CreateObject( "WScript.Shell" ).SpecialFolders( "Desktop" )
    End If
 
    If VarType(filter) <> vbString Or filter="" Then
        filter = "All files|*.*"
    End If
 
    Dim i,j, objDialog, TryObjectNames
    TryObjectNames = Array( _
        "MSComDlg.CommonDialog", _
        "MSComDlg.CommonDialog.1", _
        "Word.Application", _
        "SAFRCFileDlg.FileSave"_
        )
 
    On Error Resume Next
    Err.Clear
 
    For i=0 To UBound(TryObjectNames)
        Set objDialog = WSH.CreateObject(TryObjectNames(i))
        If Err.Number<>0 Then
            Err.Clear
        Else
            Exit For
        End If
    Next
 
    Select Case i
        Case 0,1
        ' 0.1. MSComDlg.CommonDialog MSCOMDLG32.OCX must registered.
        objDialog.InitDir = dir
        objDialog.Filter = filter
        If objDialog.ShowSave Then
            GetSaveFileName = objDialog.FileName
        End If
        Case 2
        ' 2. Word.Application Microsoft Office must installed.
        objDialog.Visible = False
        Dim objOpenDialog, filtersInArray
        filtersInArray = Split(filter, "|")
        Set objOpenDialog = _
            objDialog.Application.FileDialog( _
                msoFileDialogSaveAs)
            With objOpenDialog
            .Title = "Save File(s):"
            .InitialFileName = dir
            .Filters.Clear
            For j=0 To UBound(filtersInArray) Step 2
                .Filters.Add filtersInArray(j), _
                     filtersInArray(j+1), 1
            Next
            If .Show And .SelectedItems.Count>0 Then
                GetSaveFileName = .SelectedItems(1)
            End If
            End With
            objDialog.Visible = True
            objDialog.Quit
        Set objOpenDialog = Nothing
        Case 3
        ' 3. SAFRCFileDlg.FileSave xp 2003 only
        ' See http://www.robvanderwoude.com/vbstech_ui_fileopen.php
        If objDialog.OpenFileSaveDlg Then
           GetSaveFileName = objDialog.FileName
        End If
        Case Else
        ' Sorry I cannot do that!
    End Select
 
    Set objDialog = Nothing
End Function
 
' Test
Dim strFileName
strFileName = GetSaveFileName("C:\","All files|*.*|Microsoft Word|*.doc")

参考文档

  1. Enhance Your Apps with Common Dialogs: Part I
  2. VBScript Scripting Techniques: File Open Dialog
  3. Use a File Open Dialog Box to Populate a List Box (Windows XP-only)
  4. How Can I Show Users a Dialog Box That Only Lets Them Select Folders?
若无特别说明,本网站文章均为原创,原则上这些文章不允许转载,但是如果阁下是出于研究学习目的可以转载到阁下的个人博客或者主页,转载遵循创作共同性“署名-非商业性使用-相同方式共享”原则,请转载时注明作者出处谢绝商业性、非署名、采集站、垃圾站或者纯粹为了流量的转载。谢谢合作!

    • 参考了文章末尾列出的文档,以及找个Win7的机子自己试了一下,结果如下:
      UserAccounts.CommonDialog 不支持
      MSComDlg.CommonDialog 未注册相应ocx,不支持
      MSComDlg.CommonDialog.1 同上
      Word.Application 已安装Microsoft Office Word,支持
      SAFRCFileDlg.FileOpen 不支持
      InternetExplorer.Application 已安装IE,支持

  1. 此代码是我所见过最为强大的一个,非常棒。

    但是我在winpe2.0下测试过了,应该跟windows7的环境没有区别,就是无论你打开什么地方的文件,反馈回来的都是
    “c:\fakepath\文件全名”,怎么回事?可否有改进的地方,也就是说如果没有word,只要用IE它就有这个毛病。请支持!

      • 太彪悍了,你好熟悉那些软件环境啊,期待你植入你原来的程序中去。原来的程序好处就在于,可以选择指定的目录,可以指定选择的文件;不过你后面修改后的程序,有个bug就是当你选择某个文件后,下次你打开这个程序,它还是会指定这个文件夹或者路径下。

          • 据我了解SAFRCFileDlg.FileOpen以及InternetExplorer.Application无法设置初始目录,所以这两个排列到后面,也就是在万不得已的情况下才尝试,损失了一些特性,不过基本的选择文件任务还是可以完成的。

  2. for /f “tokens=*” %%i in (‘cscript -nologo Folder2File.vbs dir’) do (
    set OS_WIM=%%i && set “StartPath=” )

    如果我用批处理命令,如何给这个代码的DIR传递值。上面的那个好像不可以,水平有限。

      • 有两种办法可以把参数传入VBS脚本。
        方法1、采取环境变量的办法:
        test.bat批处理文件

        @ECHO OFF
        SET INITDIR=test
        CScript //NoLogo test.vbs

        test.vbs脚本文件

        Dim wshShell
        Set wshShell = CreateObject( "WScript.Shell" )
        WScript.Echo wshShell.ExpandEnvironmentStrings( "%INITDIR%" )
        Set wshShell = Nothing

        调用函数可以这样

        Dim wshShell,initdir
        Set wshShell = CreateObject( "WScript.Shell" )
        initdir = wshShell.ExpandEnvironmentStrings( "%INITDIR%" )
        Set wshShell = Nothing
        Dim strFileName
        strFileName = GetOpenFileName(initdir, _
        	"All files|*.*|Microsoft Word|*.doc")

        方法2、采取运行传参的方式:
        test.bat批处理文件

        @ECHO OFF
        CScript //NoLogo test.vbs teststring

        test.vbs脚本文件

        WScript.Echo WScript.Arguments(0)

        调用函数可以这样

        Dim strFileName
        strFileName = _
          GetOpenFileName(WScript.Arguments(0), _
          "All files|*.*|Microsoft Word|*.doc")
        • VBS的程序补充为:

          WScript.Echo WScript.Arguments(0)
          Dim strFileName, FPath
          strFileName = GetOpenFileName(WScript.Arguments(0),”All files|*.*|Microsoft Image|*.wim”)

          ‘FPath = strFileName
          If strFileName “” Then wscript.echo strFileName
          wscript.quit

        • 批处理的调用为:

          for /f “tokens=*” %%i in (‘cscript -nologo Folder2File.vbs “d:\OS_BK_IMG\OS\”‘) do (
          set OS_WIM=%%i && set “StartPath=” )

          • 我刚才测试了本机的一个路径C:\php\pear,代码应该没有问题的:

            @ECHO OFF
            for /f "tokens=*" %%i in ('cscript -nologo Folder2File.vbs "C:phppear"') do (
             set OS_WIM=%%i && set "StartPath=" )
            ECHO %OS_WIM%
            PAUSE
            'MsgBox WScript.Arguments.Count
            MsgBox WScript.Arguments(0)
             
            Dim strFileName
            strFileName = GetOpenFileName(WScript.Arguments(0), _
                           "All files|*.*|Microsoft Image|*.wim") 
             
            If strFileName<>"" Then WScript.Echo strFileName
            WScript.Quit

            不过需要注意的是,下面两个组件:
            SAFRCFileDlg.FileOpen
            InternetExplorer.Application
            包括MSHTA方案,均无法支持设置初始路径,如果依靠这个打开的话就没有什么办法了。

          • 如果有什么另外的脚本,windows系统可以支持的,又可以定位路径的话就好了,太实用了用来做批处理的时候进行文件路径的选择。

          • 恩,是可以了,非常不错。
            可否隐藏每次都会弹出来的

            msgBox WScript.Argument(0)

            这个按钮,希望它在后台运行。

          • 额,这句是测试用的,可以删去,实际只需要下面的代码即可:

            Dim strFileName
            strFileName = GetOpenFileName(WScript.Arguments(0), _
                           "All files|*.*|Microsoft Image|*.wim") 
             
            If strFileName<>"" Then WScript.Echo strFileName
            WScript.Quit
          • 谢谢,可以了。
            大哥对winPE熟悉吗?知道怎么去集成MSComDlg.CommonDialog MSCOMDLG32.OCX 吗?

          • 抱歉,对于WinPE集成不太熟悉。不过可以建议你按下面步骤尝试:
            假设实验环境和WinPE一样,系统路径位于C:\Windows\System32下。
            在实验环境中首先将MSCOMDLG32.OCX复制到C:\Windows\System32下,然后调用RegSvr32 MSCOMDLG32.OCX,这样注册表就留下了关于MSCOMDLG32.OCX的注册信息,我们只需要将这些注册信息集成到WinPE的注册表就可以了,当然也要把MSCOMDLG32.OCX复制到WinPE的系统目录下,注意确保注册表信息记录的路径和WinPE中MSCOMDLG32.OCX实际路径是否一致。
            一般注册信息位于以下注册表分支下,你可以在注册表搜索关键字MSCOMDLG32或者MSComDlg.CommonDialog

            当然如果可以的话,可以直接在WinPE系统内调用RegSvr32 MSCOMDLG32.OCX,这样最方便了。

  3. Function Browse()
    On Error Resume Next
    Dim Q2, sRet
    Q2 = chr(34)
    Browse = “”
    Set IE = CreateObject(“InternetExplorer.Application”)
    IE.visible = False
    IE.Navigate(“about:blank”)
    Do Until IE.ReadyState = 4
    Loop

    IE.Document.Write “”
    With IE.Document.all.Fil
    .focus
    .click
    ‘sRet = .value
    End With
    sRet = ie.document.script.ifile
    IE.Quit
    Set IE = Nothing
    Browse = sRet
    End Function

    Wsh.echo Browse()
    既然JS能获取就用JS获取嘛,修改一下就可以了,不过在IE不是默认浏览器的电脑上可能会有问题…

请稍后...

发表评论

电子邮件地址不会被公开。 必填项已用*标注

*