home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Chip 1998 March
/
CHIPCD_3_98.iso
/
software
/
testsoft
/
exchange
/
bin
/
exchange.dsm
< prev
next >
Wrap
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