1'************************************************************************* 2' 3' Licensed to the Apache Software Foundation (ASF) under one 4' or more contributor license agreements. See the NOTICE file 5' distributed with this work for additional information 6' regarding copyright ownership. The ASF licenses this file 7' to you under the Apache License, Version 2.0 (the 8' "License"); you may not use this file except in compliance 9' with the License. You may obtain a copy of the License at 10' 11' http://www.apache.org/licenses/LICENSE-2.0 12' 13' Unless required by applicable law or agreed to in writing, 14' software distributed under the License is distributed on an 15' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 16' KIND, either express or implied. See the License for the 17' specific language governing permissions and limitations 18' under the License. 19' 20'************************************************************************* 21'### Support Module for running macros in Word. Excel and Powerpoint 22'### using automation 23 24CONST CDA_TITLE = "Document Analysis Run Macro" 25CONST CDA_ANALYSIS_INI = "analysis.ini" 26Const CDA_ERR_STD_DELAY = 10 27Const CDA_APPNAME_WORD = "Word" 28Const CDA_APPNAME_EXCEL = "Excel" 29Const CDA_APPNAME_POWERPOINT = "Powerpoint" 30 31Dim daWrd 32Dim daDoc 33Dim daXl 34Dim daWb 35Dim daPP 36Dim daPres 37Dim daWshShell 38Dim daFso 39Dim daTitle 40 41daTitle = CDA_TITLE 42 43'# Setup Scripting objects 44set daFso = WScript.CreateObject("Scripting.FileSystemObject") 45set daWshShell = Wscript.CreateObject("Wscript.Shell") 46 47 48'##### Run Macro FUNCTIONS ###### 49 50'###################### 51Sub DASetTitle(newTitle) 52 daTitle = newTitle 53End Sub 54 55'###################### 56Sub DAsetupWrdServer 57 58On Error Resume Next 59 60Set daWrd = wscript.CreateObject("Word.Application") 61If Err.Number <> 0 Then 62 DAErrMsg "Failed to create Word Automation server: " & vbLf & vbLf & "Error: " _ 63 & CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY 64 FinalExit 65End If 66 67End Sub 68 69'###################### 70Sub DAOpenWrdDriver(driver) 71Dim sWordDriverDocPath 72 73On Error Resume Next 74daWrd.Visible = False 75 76'# Open a driver doc 77sWordDriverDocPath = daFso.GetAbsolutePathName(driver) 78'DAdiagMsg "sWordDriverDocPath : " & sWordDriverDocPath , CDIAG_STD_DELAY 79 80If Not daFso.FileExists(sWordDriverDocPath) Then 81 DAErrMsg "Driver doc does not exist: " & sWordDriverDocPath, CDA_ERR_STD_DELAY 82 FinalExit 83End If 84 85Set daDoc = daWrd.Documents.Open(sWordDriverDocPath) 86If Err.Number <> 0 Then 87 DAErrMsg "Failed to open driver doc: " & vbLf & sWordDriverDocPath & vbLf & vbLf & "Error: " _ 88 & CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY 89 FinalExit 90End If 91 92End Sub 93 94'###################### 95Function DArunWrdDriver(driver, macro) 96 97On Error Resume Next 98'# Run macro 99DArunWrdDriver = True 100daWrd.Run ("AnalysisTool." & macro) 101If Err.Number <> 0 Then 102 DAErrMsg "Failed to run macro: " & macro & vbLf & vbLf & "Error: " _ 103 & CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY 104 DArunWrdDriver = False 105End If 106 107End Function 108 109'###################### 110Sub DAsaveWrdDriver(saveDriver) 111'DAdiagMsg "saveDriver : " & saveDriver , CDIAG_STD_DELAY 112'DAdiagMsg "Abs(saveDriver) : " & daFso.GetAbsolutePathName( saveDriver) , CDIAG_STD_DELAY 113 daDoc.SaveAs daFso.GetAbsolutePathName( saveDriver) 114End Sub 115 116'###################### 117Sub DAsetupExcelServer 118 119On Error Resume Next 120 121Set daXl = wscript.CreateObject("Excel.Application") 122If Err.Number <> 0 Then 123 DAErrMsg "Failed to create Excel Automation server: " & vbLf & vbLf & "Error: " _ 124 & CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY 125 FinalExit 126End If 127 128End Sub 129 130'###################### 131Sub DAOpenExcelDriver(driver) 132 Dim sExcelDriverDocPath 133 134 On Error Resume Next 135 daXl.Visible = False 136 137 '# Open driver doc 138 sExcelDriverDocPath = daFso.GetAbsolutePathName(driver) 139 If Not daFso.FileExists(sExcelDriverDocPath) Then 140 DAErrMsg "Driver doc does not exist: " & sExcelDriverDocPath, CDA_ERR_STD_DELAY 141 FinalExit 142 End If 143 144 Set daWb = daXl.Workbooks.Open(sExcelDriverDocPath) 145 If Err.Number <> 0 Then 146 DAErrMsg "Failed to open driver doc: " & vbLf & sExcelDriverDocPath & vbLf & vbLf & "Error: " _ 147 & CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY 148 FinalExit 149 End If 150 151End Sub 152 153'###################### 154Function DArunExcelDriver(driver, macro) 155On Error Resume Next 156 157'# Run macro 158DArunExcelDriver = True 159daXl.Run ("AnalysisTool." & macro) 160If Err.Number <> 0 Then 161 DAErrMsg "Failed to run macro: " & macro & vbLf & vbLf & "Error: " _ 162 & CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY 163 DArunExcelDriver = False 164End If 165 166End Function 167 168'###################### 169Sub DAsaveExcelDriver(saveDriver) 170 '# Not overwritting - Excel hangs, need to remove file first 171 if daFso.FileExists(daFso.GetAbsolutePathName(saveDriver)) Then 172 daFso.DeleteFile(daFso.GetAbsolutePathName(saveDriver)) 173 End If 174 daWb.SaveAs daFso.GetAbsolutePathName(saveDriver) 175End Sub 176 177'###################### 178Sub DAsetupPPServer 179 180On Error Resume Next 181 182Set daPP = wscript.CreateObject("PowerPoint.Application") 183If Err.Number <> 0 Then 184 DAErrMsg "Failed to create PowerPoint Automation server: " & vbLf & vbLf & "Error: " _ 185 & CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY 186 FinalExit 187End If 188 189End Sub 190 191'###################### 192Sub DAOpenPPDriver(driver) 193Dim sPPDriverDocPath 194 195On Error Resume Next 196 197 198'# Open driver doc 199sPPDriverDocPath = daFso.GetAbsolutePathName(driver) 200If Not daFso.FileExists(sPPDriverDocPath ) Then 201 DAErrMsg "Driver doc does not exist: " & sPPDriverDocPath, CDA_ERR_STD_DELAY 202 FinalExit 203End If 204 205 206'## MS: KB Article 155073 ## 207'# PPT7: OLE Automation Error Using Open Method 208'# MUST show the PowerPoint application window at least once before calling the Application.Presentations.Open method 209daPP.Visible = True 210daPP.WindowState = 2 'Minimize PowerPoint 211 212daPP.Presentations.Open sPPDriverDocPath 213If Err.Number <> 0 Then 214 DAErrMsg "Failed to open driver doc: " & vbLf & sPPDriverDocPath & vbLf & vbLf & "Error: " _ 215 & CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY 216 FinalExit 217End If 218 219set daPres = daPP.Presentations(1) 220 221End Sub 222 223'###################### 224Function DArunPPDriver(driver, macro) 225 226On Error Resume Next 227'# Run macro 228DArunPPDriver = True 229daPP.Run (daFso.GetFileName(driver) & "!" & macro) 230If Err.Number <> 0 Then 231 DAErrMsg "Failed to run macro: " & macro & vbLf & vbLf & "Error: " _ 232 & CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY 233 DArunPPDriver = False 234End If 235 236End Function 237 238'###################### 239Sub DAsavePPDriver(saveDriver) 240 daPres.SaveAs daFso.GetAbsolutePathName(saveDriver) 241End Sub 242 243 244'###################### 245 246Sub DACloseApps() 247 '# Quit apps 248 On Error Resume Next 249 If Not daWrd Is Nothing Then 250 daDoc.Close wdDoNotSaveChanges 251 daWrd.Quit 252 End If 253 If Not daXl Is Nothing Then 254 daWb.Close False 255 daXl.Quit 256 End If 257 If Not daPP Is Nothing Then 258 daPres.Close 259 daPP.Quit 260 End If 261 262 Set daDoc = Nothing 263 Set daWb = Nothing 264 Set daPres = Nothing 265 266 Set daWrd = Nothing 267 Set daXl = Nothing 268 Set daPP = Nothing 269End Sub 270 271'###################### 272 273Sub DACleanUp() 274 '# Quit apps 275 On Error Resume Next 276 277 DACloseApps 278 279 Set daFso = Nothing 280 Set daWshShell = Nothing 281End Sub 282 283 284'###################### 285Sub DAdiagMsg( msg, delay) 286 '# WSHShell.echo: Popup if run with Wscript.exe, command line output if run with Cscript.exe 287 WScript.Echo msg 288 289 'WSHShell.popup msg, delay, daTitle, 64 290End Sub 291 292'###################### 293Sub DAErrMsg( msg, delay) 294 daWshShell.Popup msg, delay, daTitle, 16 295 296 'WScript.Echo msg 297End Sub 298 299 300'###################### 301Sub DAVerifyAnalysisIni() 302 if daFso.FileExists(daFso.GetAbsolutePathName(".\" & CDA_ANALYSIS_INI)) Then Exit Sub 303 304 DAErrMsg CDA_ANALYSIS_INI & " does not exist. " & vbLf & vbLf & _ 305 "You need to create it manually or use the DocAnalysisWizard to create one for you." & vbLf & _ 306 "Once this is done you can rerun the Document Analysis command line.", CDA_ERR_STD_DELAY 307 FinalExit 308End Sub 309 310'###################### 311Sub DAExportFile(fileName, projectFile, app_name) 312 On Error Resume Next 313 314 Dim myProject 315 316 '# Setup App Specifc VB Project 317 Set myProject = DAgetProject(fileName, projectFile, app_name) 318 319 Dim myComponent 320 Set myComponent = myProject.VBComponents(projectFile) 321 If Err.Number <> 0 Then 322 DAErrMsg "Missing Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, CERR_STD_DELAY 323 Set myComponent = Nothing 324 Set myProject = Nothing 325 FinalExit 326 End If 327 328 myProject.VBComponents(projectFile).Export fileName 329 If Err.Number <> 0 Then 330 DAErrMsg "Error exporting Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, CERR_STD_DELAY 331 Set myComponent = Nothing 332 Set myProject = Nothing 333 FinalExit 334 End If 335 336 Set myComponent = Nothing 337 Set myProject = Nothing 338 339End Sub 340 341'###################### 342Sub DAImportFile(fileName, projectFile, app_name) 343 On Error Resume Next 344 345 Dim myProject 346 347 '# Setup App Specifc VB Project 348 Set myProject = DAgetProject(fileName, projectFile, app_name) 349 350 '# Check if module already exists raise error 351 Dim myComponent 352 Set myComponent = myProject.VBComponents(projectFile) 353 If Err.Number = 0 Then 354 DAErrMsg "Duplicate Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, CERR_STD_DELAY 355 Set myComponent = Nothing 356 Set myProject = Nothing 357 FinalExit 358 End If 359 360 '#If module not there need to clear out of index error 361 Err.Clear 362 363 If Not daFso.FileExists(fileName) Then 364 DAErrMsg "Missing File " & fileName, CERR_STD_DELAY 365 Set myComponent = Nothing 366 Set myProject = Nothing 367 FinalExit 368 End If 369 370 Call myProject.VBComponents.Import(fileName) 371 372 If Err.Number <> 0 Then 373 DAErrMsg "Error importing Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, CERR_STD_DELAY 374 Set myComponent = Nothing 375 Set myProject = Nothing 376 FinalExit 377 End If 378 379 Set myComponent = Nothing 380 Set myProject = Nothing 381End Sub 382 383'################# 384 385Sub DARemoveModule(fileName, projectFile, app_name) 386 On Error Resume Next 387 388 Dim myProject 389 390 '# Setup App Specifc VB Project 391 Set myProject = DAgetProject(fileName, projectFile, app_name) 392 393 '# Check if module already exists raise error 394 Dim myComponent 395 Set myComponent = myProject.VBComponents(projectFile) 396 397 398 myProject.VBComponents.Remove myComponent 399 400 If Err.Number <> 0 Then 401 DAErrMsg "Error removing Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, CERR_STD_DELAY 402 Set myComponent = Nothing 403 Set myProject = Nothing 404 FinalExit 405 End If 406 407 Set myComponent = Nothing 408 Set myProject = Nothing 409End Sub 410 411'###################### 412Function DAgetProject(fileName, projectFile, app_name) 413 On Error Resume Next 414 415 If app_name = CDA_APPNAME_WORD Then 416 Set DAgetProject = daWrd.ActiveDocument.VBProject 417 418 ElseIf app_name = CDA_APPNAME_EXCEL Then 419 Set DAgetProject = daXl.ActiveWorkbook.VBProject 420 421 ElseIf app_name = CDA_APPNAME_POWERPOINT Then 422 Set DAgetProject = daPP.ActivePresentation.VBProject 423 End If 424 425 If Err.Number <> 0 Then 426 DAErrMsg "Cannot access VBProject for Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, _ 427 CERR_STD_DELAY 428 Set DAgetProject = Nothing 429 FinalExit 430 End If 431 432End Function 433 434