测试环境：Windows7 pro X64 + office 2010
存在问题：
1. 暂不支持命令行操作
2. 输入验证不全
3. 转换完成后pdf文件会默认打开
1 '*********************************************************************************** 2 '* 3 '* File: ConvertDocToPdf 4 '* Author: moose 5 '* Email: 852354673@qq.com 6 '* Created: 2012/12/20 7 '* Last Modified: 2012/12/20 8 '* Version: 0.1 9 '* 10 '*********************************************************************************** 11 currVbs = WScript.ScriptFullName 12 currDir = Left(currVbs, InStrRev(currVbs,"\")) 13 14 Set ws = CreateObject("wscript.shell") 15 Set word = CreateObject("word.application") 16 Set args = WScript.Arguments 17 18 19 pdfPath = "" 'pdf file path 20 21 If args.Count = 1 Then 'only input 22 docPath = args(0) 23 ElseIf args.Count = 2 Then 'only output 24 docPath = args(0) 25 pdfPath = args(1) 26 Else 'no input and output | less used 27 docPath = GetOpenFileName(currDir, "All files|*.*|Microsoft Word|*.doc|Microsoft Word 2007|*.docx") 28 End If 29 30 docToPdf docPath, pdfPath 31 32 ws.Popup "Finish convert doc to pdf ...",1,"Done" 33 34 35 36 '******************************************************************** 37 '* 38 '* Function docToPdf(input, output) 39 '* Purpose: 转换doc到pdf 40 '* Input: input : doc文件路径 41 '* output : pdf文件路径 42 '* Output: 43 '* 44 '******************************************************************** 45 Function docToPdf(input, output) 46 '默认存放位置与doc文件在同一个目录 47 If "" = Trim(input) Then 48 WScript.Quit 49 End If 50 If "" = Trim(output) Then 51 output = Left(input, InStrRev(input,".")) + "pdf" 52 End If 53 54 Set word = CreateObject("word.application") 55 Set doc = word.Documents.Open(input,1) 56 57 doc.ExportAsFixedFormat pdfPath, 17, 7, 1 '存为pdf文件 58 59 doc.Close 60 word.Quit 61 Set doc = Nothing 62 Set word = Nothing 63 End Function 64 65 66 '******************************************************************** 67 '* 68 '* Function GetOpenFileName(dir, filter) 69 '* Purpose: 打开文件选择对话框 70 '* Input: dir : 开始目录名 71 '* filter ： 过滤类型 72 '* Output: 选择的文件路径 73 '* 74 '******************************************************************** 75 Public Function GetOpenFileName(dir, filter) 76 Const msoFileDialogFilePicker = 3 77 78 If VarType(dir) <> vbString Or dir="" Then 79 dir = CreateObject( "WScript.Shell" ).SpecialFolders( "Desktop" ) 80 End If 81 82 If VarType(filter) <> vbString Or filter="" Then 83 filter = "All files|*.*" 84 End If 85 86 Dim i,j, objDialog, TryObjectNames 87 TryObjectNames = Array( _ 88 "UserAccounts.CommonDialog", _ 89 "MSComDlg.CommonDialog", _ 90 "MSComDlg.CommonDialog.1", _ 91 "Word.Application", _ 92 "SAFRCFileDlg.FileOpen", _ 93 "InternetExplorer.Application" _ 94 ) 95 96 On Error Resume Next 97 Err.Clear 98 99 For i=0 To UBound(TryObjectNames) 100 Set objDialog = WSH.CreateObject(TryObjectNames(i)) 101 If Err.Number<>0 Then 102 Err.Clear 103 Else 104 Exit For 105 End If 106 Next 107 108 Select Case i 109 Case 0,1,2 110 ' 0. UserAccounts.CommonDialog XP Only. 111 ' 1.2. MSComDlg.CommonDialog MSCOMDLG32.OCX must registered. 112 If i=0 Then 113 objDialog.InitialDir = dir 114 Else 115 objDialog.InitDir = dir 116 End If 117 objDialog.Filter = filter 118 If objDialog.ShowOpen Then 119 GetOpenFileName = objDialog.FileName 120 End If 121 Case 3 122 ' 3. Word.Application Microsoft Office must installed. 123 objDialog.Visible = False 124 Dim objOpenDialog, filtersInArray 125 filtersInArray = Split(filter, "|") 126 Set objOpenDialog = _ 127 objDialog.Application.FileDialog( _ 128 msoFileDialogFilePicker) 129 With objOpenDialog 130 .Title = "Open File(s):" 131 .AllowMultiSelect = False 132 .InitialFileName = dir 133 .Filters.Clear 134 For j=0 To UBound(filtersInArray) Step 2 135 .Filters.Add filtersInArray(j), _ 136 filtersInArray(j+1), 1 137 Next 138 If .Show And .SelectedItems.Count>0 Then 139 GetOpenFileName = .SelectedItems(1) 140 End If 141 End With 142 objDialog.Visible = True 143 objDialog.Quit 144 Set objOpenDialog = Nothing 145 Case 4 146 ' 4. SAFRCFileDlg.FileOpen xp 2003 only 147 ' See http://www.robvanderwoude.com/vbstech_ui_fileopen.php 148 If objDialog.OpenFileOpenDlg Then 149 GetOpenFileName = objDialog.FileName 150 End If 151 Case 5 152 153 Dim IEVersion,IEMajorVersion, hasCompleted 154 hasCompleted = False 155 Dim shell 156 Set shell = CreateObject("WScript.Shell") 157 ' 下面获取IE版本 158 IEVersion = shell.RegRead( _ 159 "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Version") 160 If InStr(IEVersion,".")>0 Then 161 ' 获取主版本号 162 IEMajorVersion = CInt(Left(IEVersion, InStr(IEVersion,".")-1)) 163 If IEMajorVersion>7 Then 164 ' 如果版本号大于7，也就是大于IE7，则采取MSHTA方案 165 ' Bypasses c:\fakepath\file.txt problem 166 ' http://pastebin.com/txVgnLBV 167 Dim fso 168 Set fso = CreateObject("Scripting.FileSystemObject") 169 170 Dim tempFolder : Set tempFolder = fso.GetSpecialFolder(2) 171 Dim tempName : tempName = fso.GetTempName() 172 Dim tempFile : Set tempFile = tempFolder.CreateTextFile(tempName & ".hta") 173 Dim tempBaseName 174 tempBaseName = tempFolder & "\" & tempName 175 tempFile.Write _ 176 "<html>" & _ 177 " <head>" & _ 178 " <title>Browse</title>" & _ 179 " </head>" & _ 180 " <body>" & _ 181 " <input type='file' id='f'>" & _ 182 " <script type='text/javascript'>" & _ 183 " var f = document.getElementById('f');" & _ 184 " f.click();" & _ 185 " var fso = new ActiveXObject('Scripting.FileSystemObject');" & _ 186 " var file = fso.OpenTextFile('" & _ 187 Replace(tempBaseName,"\", "\\") & ".txt" & "', 2, true);" & _ 188 " file.Write(f.value);" & _ 189 " file.Close();" & _ 190 " window.close();" & _ 191 " </script>" & _ 192 " </body>" & _ 193 "</html>" 194 tempFile.Close 195 Set tempFile = Nothing 196 Set tempFolder = Nothing 197 shell.Run tempBaseName & ".hta", 1, True 198 Set tempFile = fso.OpenTextFile(tempBaseName & ".txt", 1) 199 GetOpenFileName = tempFile.ReadLine 200 tempFile.Close 201 fso.DeleteFile tempBaseName & ".hta" 202 fso.DeleteFile tempBaseName & ".txt" 203 Set tempFile = Nothing 204 Set fso = Nothing 205 hasCompleted = True ' 标记为已完成 206 End If 207 End If 208 If Not hasCompleted Then 209 ' 5. InternetExplorer.Application IE must installed 210 objDialog.Navigate "about:blank" 211 Dim objBody, objFileDialog 212 Set objBody = _ 213 objDialog.document.getElementsByTagName("body")(0) 214 objBody.innerHTML = "<input type='file' id='fileDialog'>" 215 while objDialog.Busy Or objDialog.ReadyState <> 4 216 WScript.sleep 10 217 Wend 218 Set objFileDialog = objDialog.document.all.fileDialog 219 objFileDialog.click 220 GetOpenFileName = objFileDialog.value 221 End If 222 objDialog.Quit 223 Set objFileDialog = Nothing 224 Set objBody = Nothing 225 Set shell = Nothing 226 Case Else 227 ' Sorry I cannot do that! 228 End Select 229 230 Set objDialog = Nothing 231 End Function
