Chip 1998 March/CHIPCD_3_98.iso/software/testsoft/exchange/bin/exchange.dsm

Text File | 1997-08-25 | 10KB | 360 lines

'------------------------------------------------------------------------------
' FILE DESCRIPTION: Macros for development of Exchange Server Applications
'
' Copyright (c) Microsoft Corporation 1993-1997. All rights reserved.
'------------------------------------------------------------------------------
Option Explicit

'------------------------------------------------------------------------------
' Localized strings
'------------------------------------------------------------------------------
' Put all localizable strings and constants here
Dim ErrFailedToCreateMsg
Dim MsgOpenTitle
Dim MsgSaveAsTitle

ErrFailedToCreateMsg = "Failed to create script message"
MsgOpenTitle = "Exchange Event Script - Open"
MsgSaveAsTitle = "Exchange Event Script - Save As"

'------------------------------------------------------------------------------
' Macros
'------------------------------------------------------------------------------
' Dictionary is used to map temporary files to script messages
Dim fDictInitialized
Dim dictFilesToScriptMsgs

' MAPI Session variables
Dim amSession
Dim amStore

' Script Locator
Dim aeChooser

' Debugging Aid
Dim fDebug
'    fDebug = true
    fDebug = false

' DESCRIPTION: Select and open an Exchange Event Service script in the IDE
Sub OpenExchangeEventScript()
    On Error Resume Next

    Dim oBinding
    Dim strScriptFileName

    InitGlobals
    If Err.Number = 0 Then
        ChooseScript MsgOpenTitle, oBinding, strScriptFileName
        If Err.Number = 0 Then
            AddFileToMap strScriptFileName, oBinding
            If Err.Number = 0 Then
                Application.Documents.Open( strScriptFileName )
                If Err.Number <> 0 Then
                    RemoveFileFromMap strScriptFileName

                    ReportError "Application.Documents.Open"
                End If
            Else
                ReportError "AddFileToMap"
            End If
        ElseIf Err.Number <> &H80040113 Then
            ReportError "ChooseScript"
        End If
    ElseIf Err.Number <> &H80040113 Then
        ReportError "InitGlobals"
    End If
End Sub

' DESCRIPTION: Save an Exchange Event Service script.
Sub SaveAsExchangeEventScript()
    On Error Resume Next

    Dim strOldScriptFileName
    Dim strNewScriptFileName
    Dim oBinding
    Dim amFolder

    strOldScriptFileName = ActiveDocument.FullName
    If Err.Number = 0 Then
        InitGlobals
        If Err.Number = 0 Then
            ChooseScript MsgSaveAsTitle, oBinding, strNewScriptFileName
            If Err.Number = 0 Then
                aeChooser.DeleteTempScriptFile strNewScriptFileName

                ActiveDocument.Save(strNewScriptFileName)
                If Err.Number = 0 Then
                    If Not strOldScriptFileName Is Empty Then
                        RemoveFileFromMap strOldScriptFileName
                        aeChooser.DeleteTempScriptFile strOldScriptFileName
                    End If

                    AddFileToMap strNewScriptFileName, oBinding
                    If Err.Number = 0 Then
                        PutScript strNewScriptFileName
                    Else
                        ReportError "AddFileToMap"
                    End If
                Else
                    ReportError "Document.Save"
                End If
            ElseIf Err.Number <> &H80040113 Then
                ReportError "ChooseScript"
            End If
        ElseIf Err.Number <> &H80040113 Then
            ReportError "InitGlobals"
        End If
    Else
        Err.Description = "No document selected"
        ReportError "SaveAs"
    End If
End Sub

'------------------------------------------------------------------------------
' Events
'------------------------------------------------------------------------------

' DESCRIPTION: Document has been saved to disk.  Now copy that to the Exchange Store
Sub Application_DocumentSave(theDocument)
    On Error Resume Next

    If FileExistsInMap( theDocument.FullName ) Then
        PutScript( theDocument.FullName )
        If Err.Number <> 0 Then
            ReportError "PutScript"
        End If
    End If
End Sub

' DESCRIPTION: Document is saved and closing. Remove temporary file
Sub Application_BeforeDocumentClose(theDocument)
    On Error Resume Next

    If FileExistsInMap( theDocument.FullName ) Then
        RemoveFileFromMap theDocument.FullName
        aeChooser.DeleteTempScriptFile theDocument.FullName
' *** commented out because this is booted til osmium RTM ***
'    ElseIf InStr(theDocument.Name, ".asp", 1) > 1 Then
'        InitChooser
'        If Err.Number = 0 Then
'            aeChooser.SetFileCloseEvent theDocument.FullName
'            If Err.Number <> 0 And Err.Number <> &H80070002 And Err.Number <> &H8007007B Then
'                ReportError "SetFileCloseEvent"
'            End If
'        Else
'            ReportError "InitChooser"
'        End If
    End If
End Sub

' DESCRIPTION: VS is exiting. Final cleanup
Sub Application_BeforeApplicationShutDown()
    On Error Resume Next

    ClearMap

    If Not aeChooser Is Nothing Then
        Set aeChooser = Nothing
    End If

    If Not amSession Is Nothing Then
        amSession.Logoff
        Set amSession = Nothing
    End If

    Err.Clear
End Sub

'------------------------------------------------------------------------------
' Helpers
'------------------------------------------------------------------------------

' DESCRIPTION: Prompt user for an Exchange Event Service script
Private Sub ChooseScript(strTitle, ByRef oBinding, ByRef strScriptFileName)
    On Error Resume Next

    Err.Clear

    aeChooser.ChooseScript strTitle
    If Err.Number = 0 Then
        Set oBinding = aeChooser.Binding
        If Err.Number = 0 Then
            strScriptFileName = aeChooser.FileName
            If Err.Number <> 0 Then
                ReportError "ScriptChooser.FileName"
            End If
        Else
            ReportError "ScriptChooser.Binding"
        End If
    ElseIf Err.Number <> &H80040113 Then
        ReportError "ScriptChooser.ChooseScript"
    End If

    Application.Active = true
End Sub

' DESCRIPTION: Save an Exchange Event Service script to the Exchange Store
Private Sub PutScript(ByVal strScriptFileName)
    On Error Resume Next

    Dim oBinding

    FindScriptMsgInMap strScriptFileName, oBinding
    If Err.Number = 0 Then
        aeChooser.PutScript oBinding, strScriptFileName
    Else
        ReportError "FindScriptMsgInMap"
    End If
End Sub

Private Sub ReportError(strWhatFailed)
    Dim strErrMsg

    strErrMsg = strWhatFailed & " failed: " & Err.Description & " (" & Hex(Err.Number) & ")"

    MsgBox( strErrMsg )
End Sub

'------------------------------------------------------------------------------
' MAPI Functions
'------------------------------------------------------------------------------

' DESCRIPTION:  Initialize MAPI, logon to Exchange Store, and initialize script chooser
Private Sub InitChooser
    On Error Resume Next

    If aeChooser Is Nothing Then
        Err.Clear

        Set aeChooser = CreateObject("ActiveEx.ScriptChooser")
    End If
End Sub

Private Sub InitGlobals
    On Error Resume Next

    Dim amTempSession

    If amSession Is Nothing Then
        Err.Clear

        Set amTempSession = CreateObject("MAPI.Session")
        If Err.Number = 0 Then
            ' Logon with showDialog:=true, newSession:=false, NoMail:=true
            amTempSession.Logon "", "", true, true, -1, true
            If Err.Number = 0 Then
                InitChooser
                If Err.Number = 0 Then
                    aeChooser.Session = amTempSession
                    If Err.Number = 0 Then
                        aeChooser.Root = amTempSession
                        If Err.Number = 0 Then
                            Set amSession = amTempSession
                        Else
                            ReportError "ScriptChooser.Root"
                        End If
                    Else
                        ReportError "ScriptChooser.Session"
                    End If
                Else
                    ReportError "InitChooser"
                End If
            ElseIf Err.Number <> &H80040113 Then
                ReportError "Session.Logon"
            End If

            Set amTempSession = Nothing
        Else
            ReportError "CreateObject"
        End If
    End If
End Sub

'------------------------------------------------------------------------------
' Map of Files to Script Messages
'------------------------------------------------------------------------------

' DESCRIPTION: Adds a File/ScriptMsg pair to the dictionary
Private Sub AddFileToMap( ByVal keyFile, item)
    On Error Resume Next

    If Not fDictInitialized Then
        Set dictFilesToScriptMsgs = CreateObject("Scripting.Dictionary")
        If Err.Number = 0 Then
            fDictInitialized = true
        Else
            ReportError "CreateObject"
            Exit Sub
        End If
    End If

    dictFilesToScriptMsgs.CompareMode = vbTextCompare

    dictFilesToScriptMsgs.Add keyFile, item
    If Err.Number <> 0 Then
        ReportError "Dictionary.Add"
    End If
End Sub

'DESCRIPTION: Removes a File/ScriptMsg pair from dictionary
Private Sub RemoveFileFromMap( ByVal keyFile )
    On Error Resume Next

    If Not fDictInitialized Then
        Exit Sub
    End If

    dictFilesToScriptMsgs.Remove(keyFile)
    If Err.Number <> 0 And Err.Number <> &H802b Then
        ReportError "Dictionary.Remove"
    End If
End Sub

' DESCRIPTION: Checks if the File exists in the dictionary
Private Function FileExistsInMap( ByVal keyFile )
    On Error Resume Next

    If Not fDictInitialized Then
        FileExistsInMap = false
        Exit Function
    End If

    FileExistsInMap = dictFilesToScriptMsgs.Exists(keyFile)
    If Err.Number <> 0 Then
        ReportError "Dictionary.Exists"
    End If
End Function

' DESCRIPTION: Finds the ScriptMsg corresponding to the File in the dictionary
Private Sub FindScriptMsgInMap(ByVal keyFile, ByRef item)
    On Error Resume Next

    If Not fDictInitialized Then
        Exit Sub
    End If

    Set item = dictFilesToScriptMsgs.Item(keyFile)
    If Err.Number <> 0 Then
        ReportError "Dictionary.Item"
    End If
End Sub

' DESCRIPTION: Cleans the map up
Private Sub ClearMap()
    On Error Resume Next

    If Not fDictInitialized Then
        Exit Sub
    End If

    fDictInitialized = false

    dictFilesToScriptMsgs.RemoveAll
    If Err.Number <> 0 Then
        ReportError "Dictionary.RemoveAll"
    End If

    Set dictFilesToScriptMsgs = Nothing
End Sub