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