Ao send branch.mmbas

From ActivityOwnerWiki
Jump to: navigation, search
Option Explicit
'ao_send_branch 08Dec09 http://www.activityowner.com  http://creativecommons.org/licenses/by-sa/3.0/
'
'08Dec09 testing addition of authentication option
Sub Main
 Dim schema As String
 Dim objMessage As Object
 Dim configdocname As String
 Dim configdoc As Document
 Dim dashboarddoc As Document
 Dim t As Topic
 configdocname=GetPath(mmDirectoryMyMaps) & "\AO\emailconfig.mmap"
 Set dashboarddoc = ActiveDocument
 On Error GoTo X
 Set configdoc=Documents.Open(configdocname,"",False)
 On Error GoTo 0
 If Err.Number>0 Then
    X: Set configdoc=Documents.Add
    configdoc.CentralTopic.Text="ao_send_branch.mmbas configuration file"
 End If
 createattribute "smtp",       "Enter your SMTP for your ISP (e.g. smtp.domain.com)" , configdoc
 createattribute "fromemail",  "Enter from address for outgoing email"				, configdoc
 createattribute  "toemail",   "Enter to address for outgoing email"				, configdoc
  createattribute "serverport", "Enter port to use (25 typical, 465 for gmail)"		, configdoc
 createattribute "youruserid", "Enter your userid (only if authentication required)" , configdoc
 createattribute  "yourpassword", "Enter your password (only if authentication required)" , configdoc
 createattribute "authenticate", "Enter 1 if you need to authenticate (otherwise enter 0)", configdoc
configdoc.SaveAs(configdocname)
dashboarddoc.Activate
schema="http://schemas.microsoft.com/cdo/configuration/"
Set objMessage = CreateObject("CDO.Message")
ActiveDocument.Selection.PrimaryTopic.SetLevelOfDetail(10)
ActiveDocument.Selection.Copy
With objMessage
 .Subject =  ActiveDocument.Selection.PrimaryTopic.Text
 .From = getattribute("fromemail",configdoc)
 .To =   getattribute("toemail",configdoc)
 .TextBody = Clipboard
End With
With objMessage.Configuration.Fields
  .Item(schema & "sendusing") = 2
  .Item(schema & "smtpserver") = getattribute("smtp",configdoc)
  .Item(schema & "smtpserverport") = Eval(getattribute("serverport",configdoc))
  .Item(schema & "smtpauthenticate") = Eval(getattribute("authenticate",configdoc))
  If Not getattribute("yourpassword",configdoc)="" Then
    .Item(schema & "smtpauthenticate")= 1 'clear text
  	.Item(schema & "sendusername") = getattribute("youruserid", configdoc)
  	.Item(schema & "sendpassword") = getattribute("yourpassword",configdoc)
  	.Item(schema & "smtpusessl") = True
  	.Item(schema & "smtpconnectiontimeout")= Eval(getattribute("serverport",configdoc))
  End If
  .Update
End With
On Error GoTo Y
objMessage.send
On Error GoTo 0
If Err.Number>0 Then
 Y: MsgBox("Error trying to send message via " & getattribute("smpt",configdoc) & ":" & Err.Description)
 End If
 configdoc.Close
End Sub
Function getattribute(a As String,d As Document) As String
   Dim mtopic As Topic
	For Each mtopic In d.CentralTopic.AllSubTopics
	  If a=mtopic.Text Then getattribute = mtopic.Notes.Text
	Next
End Function
Sub createattribute(a As String,s As String, d As Document)
   Dim mtopic As Topic
   Dim atopic As Topic
   Dim found As Boolean
   found=False
	For Each mtopic In d.CentralTopic.AllSubTopics
	  If a=mtopic.Text Then
	  	found=True
	  	Set atopic = mtopic
	  End If
    Next
	If Not found Then
	  	Set atopic=d.CentralTopic.AddSubTopic(a)
	    atopic.Notes.Text=InputBox(s)
	End If
End Sub