xref: /trunk/main/migrationanalysis/src/driver_docs/DocAnalysisRunMacro.vbs (revision 96eff784)

'*************************************************************************
'
'  Licensed to the Apache Software Foundation (ASF) under one
'  or more contributor license agreements.  See the NOTICE file
'  distributed with this work for additional information
'  regarding copyright ownership.  The ASF licenses this file
'  to you under the Apache License, Version 2.0 (the
'  "License"); you may not use this file except in compliance
'  with the License.  You may obtain a copy of the License at
'
'    http://www.apache.org/licenses/LICENSE-2.0
'
'  Unless required by applicable law or agreed to in writing,
'  software distributed under the License is distributed on an
'  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
'  KIND, either express or implied.  See the License for the
'  specific language governing permissions and limitations
'  under the License.
'
'*************************************************************************
'### Support Module for running macros in Word. Excel and PowerPoint
'### using automation

CONST CDA_TITLE = "Document Analysis Run Macro"
CONST CDA_ANALYSIS_INI = "analysis.ini"
Const CDA_ERR_STD_DELAY = 10
Const CDA_APPNAME_WORD = "Word"
Const CDA_APPNAME_EXCEL = "Excel"
Const CDA_APPNAME_POWERPOINT = "PowerPoint"

Dim daWrd
Dim daDoc
Dim daXl
Dim daWb
Dim daPP
Dim daPres
Dim daWshShell
Dim daFso
Dim daTitle

daTitle = CDA_TITLE

'# Setup Scripting objects
set daFso = WScript.CreateObject("Scripting.FileSystemObject")
set daWshShell = Wscript.CreateObject("Wscript.Shell")


'##### Run Macro FUNCTIONS ######

'######################
Sub DASetTitle(newTitle)
	daTitle = newTitle
End Sub

'######################
Sub DAsetupWrdServer

On Error Resume Next

Set daWrd = wscript.CreateObject("Word.Application")
If Err.Number <> 0 Then
	DAErrMsg "Failed to create Word Automation server: " & vbLf & vbLf & "Error: " _
		& CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY
	FinalExit
End If

End Sub

'######################
Sub DAOpenWrdDriver(driver)
Dim sWordDriverDocPath

On Error Resume Next
daWrd.Visible = False

'# Open a driver doc
sWordDriverDocPath = daFso.GetAbsolutePathName(driver)
'DAdiagMsg "sWordDriverDocPath : " & sWordDriverDocPath  , CDIAG_STD_DELAY

If Not daFso.FileExists(sWordDriverDocPath) Then
	DAErrMsg "Driver doc does not exist: " & sWordDriverDocPath, CDA_ERR_STD_DELAY
    	FinalExit
End If

Set daDoc = daWrd.Documents.Open(sWordDriverDocPath)
If Err.Number <> 0 Then
	DAErrMsg "Failed to open driver doc: " & vbLf & sWordDriverDocPath & vbLf & vbLf & "Error: " _
		& CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY
	FinalExit
End If

End Sub

'######################
Function DArunWrdDriver(driver, macro)

On Error Resume Next
'# Run macro
DArunWrdDriver = True
daWrd.Run ("AnalysisTool." & macro)
If Err.Number <> 0 Then
	DAErrMsg "Failed to run macro: " & macro & vbLf & vbLf & "Error: " _
		& CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY
	DArunWrdDriver = False
End If

End Function

'######################
Sub DAsaveWrdDriver(saveDriver)
'DAdiagMsg "saveDriver : " & saveDriver  , CDIAG_STD_DELAY
'DAdiagMsg "Abs(saveDriver) : " & daFso.GetAbsolutePathName( saveDriver)  , CDIAG_STD_DELAY
	daDoc.SaveAs daFso.GetAbsolutePathName( saveDriver)
End Sub

'######################
Sub DAsetupExcelServer

On Error Resume Next

Set daXl = wscript.CreateObject("Excel.Application")
If Err.Number <> 0 Then
	DAErrMsg "Failed to create Excel Automation server: " & vbLf & vbLf & "Error: " _
		& CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY
	FinalExit
End If

End Sub

'######################
Sub DAOpenExcelDriver(driver)
    Dim sExcelDriverDocPath

    On Error Resume Next
    daXl.Visible = False

    '# Open driver doc
    sExcelDriverDocPath = daFso.GetAbsolutePathName(driver)
    If Not daFso.FileExists(sExcelDriverDocPath) Then
        DAErrMsg "Driver doc does not exist: " & sExcelDriverDocPath, CDA_ERR_STD_DELAY
        FinalExit
    End If

    Set daWb = daXl.Workbooks.Open(sExcelDriverDocPath)
    If Err.Number <> 0 Then
        DAErrMsg "Failed to open driver doc: " & vbLf & sExcelDriverDocPath & vbLf & vbLf & "Error: " _
            & CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY
        FinalExit
    End If

End Sub

'######################
Function DArunExcelDriver(driver, macro)
On Error Resume Next

'# Run macro
DArunExcelDriver = True
daXl.Run ("AnalysisTool." & macro)
If Err.Number <> 0 Then
	DAErrMsg "Failed to run macro: " & macro & vbLf & vbLf & "Error: " _
		& CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY
	DArunExcelDriver = False
End If

End Function

'######################
Sub DAsaveExcelDriver(saveDriver)
	'# Not overwritting - Excel hangs, need to remove file first
	if daFso.FileExists(daFso.GetAbsolutePathName(saveDriver)) Then
		daFso.DeleteFile(daFso.GetAbsolutePathName(saveDriver))
	End If
	daWb.SaveAs daFso.GetAbsolutePathName(saveDriver)
End Sub

'######################
Sub DAsetupPPServer

On Error Resume Next

Set daPP = wscript.CreateObject("PowerPoint.Application")
If Err.Number <> 0 Then
	DAErrMsg "Failed to create PowerPoint Automation server: " & vbLf & vbLf & "Error: " _
		& CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY
	FinalExit
End If

End Sub

'######################
Sub DAOpenPPDriver(driver)
Dim sPPDriverDocPath

On Error Resume Next


'# Open driver doc
sPPDriverDocPath = daFso.GetAbsolutePathName(driver)
If Not daFso.FileExists(sPPDriverDocPath ) Then
	DAErrMsg "Driver doc does not exist: " & sPPDriverDocPath, CDA_ERR_STD_DELAY
    	FinalExit
End If


'## MS: KB Article 155073 ##
'# PPT7: OLE Automation Error Using Open Method
'# MUST show the PowerPoint application window at least once before calling the Application.Presentations.Open method
daPP.Visible = True
daPP.WindowState = 2 'Minimize PowerPoint

daPP.Presentations.Open sPPDriverDocPath
If Err.Number <> 0 Then
	DAErrMsg "Failed to open driver doc: " & vbLf & sPPDriverDocPath & vbLf & vbLf & "Error: " _
		& CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY
	FinalExit
End If

set daPres = daPP.Presentations(1)

End Sub

'######################
Function DArunPPDriver(driver, macro)

On Error Resume Next
'# Run macro
DArunPPDriver = True
daPP.Run (daFso.GetFileName(driver) & "!" & macro)
If Err.Number <> 0 Then
	DAErrMsg "Failed to run macro: " & macro & vbLf & vbLf & "Error: " _
		& CStr(Err.Number) & " " & Err.Description, CDA_ERR_STD_DELAY
	DArunPPDriver = False
End If

End Function

'######################
Sub DAsavePPDriver(saveDriver)
	daPres.SaveAs daFso.GetAbsolutePathName(saveDriver)
End Sub


'######################

Sub DACloseApps()
    '# Quit apps
    On Error Resume Next
    If Not daWrd Is Nothing Then
        daDoc.Close wdDoNotSaveChanges
        daWrd.Quit
    End If
    If Not daXl Is Nothing Then
        daWb.Close False
        daXl.Quit
    End If
    If Not daPP Is Nothing Then
        daPres.Close
        daPP.Quit
    End If

    Set daDoc = Nothing
    Set daWb = Nothing
    Set daPres = Nothing

    Set daWrd = Nothing
    Set daXl = Nothing
    Set daPP = Nothing
End Sub

'######################

Sub DACleanUp()
    '# Quit apps
    On Error Resume Next

    DACloseApps

    Set daFso = Nothing
    Set daWshShell = Nothing
End Sub


'######################
Sub DAdiagMsg( msg, delay)
	'# WSHShell.echo: Popup if run with Wscript.exe, command line output if run with Cscript.exe
	WScript.Echo msg

	'WSHShell.popup msg, delay, daTitle, 64
End Sub

'######################
Sub DAErrMsg( msg, delay)
	daWshShell.Popup msg, delay, daTitle, 16

	'WScript.Echo msg
End Sub


'######################
Sub DAVerifyAnalysisIni()
	if daFso.FileExists(daFso.GetAbsolutePathName(".\" & CDA_ANALYSIS_INI)) Then Exit Sub

	DAErrMsg CDA_ANALYSIS_INI & " does not exist. " & vbLf & vbLf & _
		"You need to create it manually or use the DocAnalysisWizard to create one for you." & vbLf & _
		"Once this is done you can rerun the Document Analysis command line.", CDA_ERR_STD_DELAY
    	FinalExit
End Sub

'######################
Sub DAExportFile(fileName, projectFile, app_name)
    On Error Resume Next

    Dim myProject

    '# Setup App Specifc VB Project
    Set myProject = DAgetProject(fileName, projectFile, app_name)

    Dim myComponent
    Set myComponent = myProject.VBComponents(projectFile)
    If Err.Number <> 0 Then
	DAErrMsg "Missing Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, CERR_STD_DELAY
    	Set myComponent = Nothing
	Set myProject = Nothing
	FinalExit
    End If

    myProject.VBComponents(projectFile).Export fileName
    If Err.Number <> 0 Then
	DAErrMsg "Error exporting Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, CERR_STD_DELAY
    	Set myComponent = Nothing
	Set myProject = Nothing
	FinalExit
    End If

    Set myComponent = Nothing
    Set myProject = Nothing

End Sub

'######################
Sub DAImportFile(fileName, projectFile, app_name)
    On Error Resume Next

    Dim myProject

    '# Setup App Specifc VB Project
    Set myProject = DAgetProject(fileName, projectFile, app_name)

    '# Check if module already exists raise error
    Dim myComponent
    Set myComponent = myProject.VBComponents(projectFile)
    If Err.Number = 0 Then
        DAErrMsg "Duplicate Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, CERR_STD_DELAY
        Set myComponent = Nothing
        Set myProject = Nothing
        FinalExit
    End If

    '#If module not there need to clear out of index error
    Err.Clear

    If Not daFso.FileExists(fileName) Then
        DAErrMsg "Missing File " & fileName, CERR_STD_DELAY
        Set myComponent = Nothing
        Set myProject = Nothing
        FinalExit
    End If

    Call myProject.VBComponents.Import(fileName)

    If Err.Number <> 0 Then
        DAErrMsg "Error importing Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, CERR_STD_DELAY
    	Set myComponent = Nothing
        Set myProject = Nothing
        FinalExit
    End If

    Set myComponent = Nothing
    Set myProject = Nothing
End Sub

'#################

Sub DARemoveModule(fileName, projectFile, app_name)
     On Error Resume Next

    Dim myProject

    '# Setup App Specifc VB Project
    Set myProject = DAgetProject(fileName, projectFile, app_name)

    '# Check if module already exists raise error
    Dim myComponent
    Set myComponent = myProject.VBComponents(projectFile)


    myProject.VBComponents.Remove myComponent

    If Err.Number <> 0 Then
	DAErrMsg "Error removing Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, CERR_STD_DELAY
    	Set myComponent = Nothing
	Set myProject = Nothing
	FinalExit
    End If

    Set myComponent = Nothing
    Set myProject = Nothing
End Sub

'######################
Function DAgetProject(fileName, projectFile, app_name)
    On Error Resume Next

    If app_name = CDA_APPNAME_WORD Then
	Set DAgetProject = daWrd.ActiveDocument.VBProject

    ElseIf app_name = CDA_APPNAME_EXCEL Then
	Set DAgetProject = daXl.ActiveWorkbook.VBProject

    ElseIf app_name = CDA_APPNAME_POWERPOINT Then
	Set DAgetProject = daPP.ActivePresentation.VBProject
    End If

    If Err.Number <> 0 Then
	DAErrMsg "Cannot access VBProject for Project File [" & projectFile & "] - Path:" & vbLf & vbLf & fileName, _
		CERR_STD_DELAY
	Set DAgetProject = Nothing
	FinalExit
    End If

End Function