OLK2K3: Programmatically sending message(s) to recipient.

B

Bill Billmire

I have some code that programmatically sends a message to a specified
recipient, after a cmdClick() event. I used a "call" statement to execute
the "message sending" sub-routine.

Question: When this code runs, it makes me re-evaluate the variables and
fields that have already been defined and populated with data (in previous
sub-routines). It seems to be doing that processing again... I just want to
reference the fields and use the existing data.

Question: When this "message sending" routine runs, I get two Outlook
(security) pop-ups -- One indicating that, "A program is trying to access
e-mail addresses you have stored in Outlook. Do you want to allow this?" and
another shortly after I respond (yes) stating, "A program is trying to
automatically send e-mail on your behalf. Do you want to allow this?", again
I respond (yes) and the message gets sent. Can these pop-up be supressed if
the Outlook form is "trusted" deemed safe to perform these operations?

Question: I just need a Code Review on what I have working and any
suggestions/comments on better ways to accomplish the same goal.

Thanks in advance! Code follows...

Function UpdateTicket_Click()
Item.Save
Call NotifyUser
End Function

'--------------Send Update to User---------------

Sub NotifyUser()
Dim myOlApp 'as New Outlook.Application
Dim myItem 'as Outlook.MailItem
Dim myNotify
Dim olMailItem
Dim myRecipient 'as Outlook.Recipient
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
strDispName =
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("FullName").Value
TicketID = Item.UserProperties.Find("TicketID").Value
Set myRecipient = myItem.Recipients.Add(strDispName)
' If myNotify.Updated Then
myItem.Subject = "Updates have occurred on your OSR, Ticket ID: " & TicketID
myItem.Body = "To review the updates to your Help Desk Ticket, look in
Public Folders (Help Desk Queue)."
myItem.Display
myItem.Send
' End If
End Sub
 
S

Sue Mosher [MVP-Outlook]

Q1: What variables are you concerned about? I see only procedure-level
variables, not module-level variables.

Q2: See http://www.outlookcode.com/d/sec.htm for your options with regard to
the "object model guard" security in Outlook 2000 SP2 and later versions.
 
B

Bill Billmire

Hi Sue!

Below is the code for the entire module. The two fields/variables I am
concerned with in the "Notify User" sub-routine are "Fullname" and
"TicketID". These fields (on the Outlook Form) will always be populated on
the (Edit Read Page), so I should be able to just retrieve the data from
those fields [Right?]?

Thanks for the info on the "object model guard", I will review and see what
I can do to implement the suggestions and mitigate the impacts of the two
pop-ups.

Regards,
Bill Billmire -

'-----------------OnLine Service Request-------------------
'----Code Updated on January 12 2005 by Bill Billmire----
'-----------Added Printing Routine (1/10/2005)------------
'---------Added Notify User Routine (1/12/2005)----------

Option Explicit

'----------Ticket ID & Window Size and Placement---------

Dim UserName
Dim Trimmed
Dim TicketID
Dim NowID
Dim MyDate
Dim objInspector ' Inspector object

Sub Item_Open()
If Item.CreationTime = #1/1/4501# Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 485
Set objInspector = Nothing
ElseIf Item.Size <> 0 Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 665
Set objInspector = Nothing
End If
If (Item.SenderName = "") Then
UserName = Application.GetNameSpace("MAPI").CurrentUser
Trimmed = TrimUserName(UserName)
NowID = Now
MyDate = CreateDateAsNumber(NowID)
TicketID = Trimmed & MyDate
Item.UserProperties.Find("TicketID").Value = TicketID
End If
End Sub
Function TrimUserName(ByVal UserName)

Dim CharName
Dim AscName
Dim KeepName
Dim RightName
Dim i
KeepName = ""

For i = 0 To 2
CharName = Mid(UCase(UserName), i + 1, 1)
AscName = Asc(CharName)
If ((AscName >= 48) and (AscName <= 57)) or ((AscName >= 65) and (AscName
<=90)) Then
KeepName = KeepName + CStr(AscName)
End If
Next
RightName = Right(KeepName, 6)
TrimUserName = RightName
End Function

Function CreateDateAsNumber(ByVal NowID)
Dim i
Dim CharName
Dim AscName
Dim KeepName
Dim RightID
For i = 0 To 16
CharName = Mid(UCase(NowID), i + 1, 1)
AscName = Asc(CharName)
If ((AscName >= 48) and (AscName <= 57)) Then
KeepName = KeepName + CStr(CharName)
End If
Next
RightID = Right(KeepName, 6)
CreateDateAsNumber = RightID
End Function

'-------Online_Service_Request-Command Buttons-----------

Dim MyNameSpace

Function UpdateTicket_Click()
Item.Save
Call NotifyUser
End Function

Function ClosedBy_Click()
Set MyNameSpace = Application.GetNameSpace("MAPI")
Item.UserProperties.Find("ClosedBy").Value = MyNameSpace.CurrentUser
End Function

'-------------------Autofill Section---------------------

Dim strUserName ' UserName
Dim strRetCode ' Return Code of MAPI Logon
Dim strDeptName ' Department Name
Dim strDispName ' Display Name
Dim strCust1 ' Custom attribute field 1
Dim strCust2 ' Custom attribute field 2
Dim objSession ' MAPI Session
Dim objAddrEntries ' Current Object
Dim objFilter ' Address Entry Filter
Dim objDisplayName ' DisplayName
Dim objAddressEntry ' Current Address Entry

Set objInspector = Nothing
Set objAddrEntries = Nothing
Set objAddressEntry = Nothing

' MAPI property tags for the most common mailbox properties
Public Const CdoPR_MHS_COMMON_NAME = &H3A0F001E ' Offline Alias
Public Const CdoPR_DISPLAY_NAME = &H3001001E ' DisplayName
Public Const CdoPR_DEPARTMENT_NAME = &H3A18001E ' Department Name
'Public Const CdoPR_BUSINESS_TELEPHONE_NUMBER = &H3A08001E ' Phone and
Business phone

' Custom Attribute MAPI property tags
Public Const PR_EMS_AB_EXTENSION_ATTRIBUTE_1 = &H802D001E
Public Const PR_EMS_AB_EXTENSION_ATTRIBUTE_2 = &H802E001E
Public Const strServer = "MyServer"
Public Const strMailbox = "MyMailbox"

Function SetName_Click()
Set MyNameSpace = Application.GetNameSpace("MAPI")
Item.UserProperties.Find("Fullname").Value = MyNameSpace.Currentuser
Set strUserName = MyNameSpace.currentuser
' Create session
Set objSession = Application.CreateObject("MAPI.Session")
strRetCode = objSession.Logon(strUserName, "", False, False, 0)
' strRetCode =
objSession.Logon(Application.GetNameSpace("MAPI").CurrentUser, "", False,
False, 0)
' If strUserName not found
If Trim(strUserName) = "" Then
' Error creating session, show error message and exit
MsgBox "Undefinied error. Errorcode: " & strRetCode & ". Please contact
your System Administrator", 48, "Microsoft Outlook"
Item_Open = False
Else
strRetCode = "OK"
End If

' Set Subject (it looks better than <untitled>, or ?)
Item.Subject = "Online Service Request"
Set objAddrEntries = objSession.AddressLists("Global Address
List").AddressEntries
Set objFilter = objAddrEntries.Filter
objFilter.Fields.Add CdoPR_DISPLAY_NAME, strUserName
For Each objAddressEntry In objAddrEntries
On Error Resume Next
strDispName = objAddressEntry.Fields (CdoPR_DISPLAY_NAME).Value
strDeptName = objAddressEntry.Fields (CdoPR_DEPARTMENT_NAME).Value
strCust1 = objAddressEntry.Fields
(PR_EMS_AB_EXTENSION_ATTRIBUTE_1).Value
strCust2 = objAddressEntry.Fields
(PR_EMS_AB_EXTENSION_ATTRIBUTE_2).Value
Next

Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("FullName").Value = strDispName
If Trim(strDeptName) <> "" Then
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("DepartmentName").Value = strDeptName
End If
If Trim(strCust1) <> "" Then
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("DepartmentNumber").Value = strCust1
End If
If Trim(strCust2) <> "" Then
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("PhoneExtension").Value = strCust2
End If

End Function
'----------------------Printing Routine------------------------
Dim objWord
Dim strTemplate
Dim strField
Dim strField1
Dim objDoc
Dim objMark
Dim mybklist
Dim counter

Sub cmdPrint_Click()

Item.Save
Set objWord = CreateObject("Word.Application")

' Put the name of the Word template that contains the bookmarks
strTemplate = "OSR.dot"

' Location of Word template; could be on a shared LAN
strTemplate = "\\ivory\forms\" & strTemplate

Set objDoc = objWord.Documents.Add(strTemplate)
Set mybklist = objDoc.Bookmarks

For counter = 1 to mybklist.count
Set objMark = objDoc.Bookmarks(counter)
strField = objMark.Name
If strField = "SentField" then
strField1 = CStr(Item.SentOn)
ElseIf strField = True then
objDoc.FormFields(objMark.Name).CheckBox.Value = True
ElseIf strField = False then
objDoc.FormFields(objMark.Name).CheckBox.Value = False
Else
strField1 = Item.UserProperties(strField)
End If
objMark.Range.InsertBefore strField1
Next
msgbox "Printing to " & objWord.ActivePrinter
objDoc.PrintOut 0
objWord.Quit(0)
' Clean Up
' objDoc = Nothing
' objWord = Nothing
End Sub

'--------------Send Update to User---------------
Sub NotifyUser()
Dim myOlApp 'as New Outlook.Application
Dim myItem 'as Outlook.MailItem
Dim myNotify
Dim olMailItem
Dim myRecipient 'as Outlook.Recipient
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
strDispName =
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("FullName").Value
TicketID = Item.UserProperties.Find("TicketID").Value
Set myRecipient = myItem.Recipients.Add(strDispName)
' If myNotify.Updated Then
myItem.Subject = "Updates have occurred on your OSR, Ticket ID: " & TicketID
myItem.Body = "To review the updates to your Help Desk Ticket, look in
Public Folders (Help Desk Queue)."
myItem.Display
myItem.Send
' End If
End Sub
'-------------------CDO Installation Routine---------------------

'Function IsCDOInstalled()
'Dim testCDOobj
' On Error Resume Next
' Set testCDOobj = Application.CreateObject("MAPI.Session")
' If Err.Number <> 0 Then
' IsCDOInstalled = False
' Else
' IsCDOInstalled = True
' end if
' If Not testCDOobj Is Nothing Then
' Set testCDOobj = Nothing
' End If
' Exit Function
'End Function

'Function InstallCDO()

'Dim blnSuccess
'Dim objInstaller
'Dim strProductId, strFeatureName
' On Error Resume Next
' Set objInstaller = Application.CreateObject("WindowsInstaller.Installer")
' strProductId = Application.ProductCode
' strFeatureName = "OutlookCDO"
' If objInstaller.FeatureState(strProductId, strFeatureName) <> 3 Then
' objInstaller.ConfigureFeature strProductId, strFeatureName, 3
' If Err.Number <> 0 Then
' blnSuccess = False
' Else
' blnSuccess = True
' End If
' Else
' blnSuccess = True
' End If
' Install = blnSuccess
'End Function
 
S

Sue Mosher [MVP-Outlook]

So you're not concerned about variables at all but about Outlook property
values? I'm confused now. I don't understand what you mean by "re-evaluate
variables" in your original post.

You are correct, though, that you would retrieve the values through the
UserProperties collection, preferably without FInd:

Item.UserProperties("TicketID")

You should not be reading or setting control values unless they are unbound
controls. Use property values instead.

I also see that you have a TicketID module-level variable, but you set it at
least twice. Is there a reason for that?
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Bill Billmire said:
Below is the code for the entire module. The two fields/variables I am
concerned with in the "Notify User" sub-routine are "Fullname" and
"TicketID". These fields (on the Outlook Form) will always be populated
on
the (Edit Read Page), so I should be able to just retrieve the data from
those fields [Right?]?


'-----------------OnLine Service Request-------------------
'----Code Updated on January 12 2005 by Bill Billmire----
'-----------Added Printing Routine (1/10/2005)------------
'---------Added Notify User Routine (1/12/2005)----------

Option Explicit

'----------Ticket ID & Window Size and Placement---------

Dim UserName
Dim Trimmed
Dim TicketID
Dim NowID
Dim MyDate
Dim objInspector ' Inspector object

Sub Item_Open()
If Item.CreationTime = #1/1/4501# Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 485
Set objInspector = Nothing
ElseIf Item.Size <> 0 Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 665
Set objInspector = Nothing
End If
If (Item.SenderName = "") Then
UserName = Application.GetNameSpace("MAPI").CurrentUser
Trimmed = TrimUserName(UserName)
NowID = Now
MyDate = CreateDateAsNumber(NowID)
TicketID = Trimmed & MyDate
Item.UserProperties.Find("TicketID").Value = TicketID
End If
End Sub
Function TrimUserName(ByVal UserName)

Dim CharName
Dim AscName
Dim KeepName
Dim RightName
Dim i
KeepName = ""

For i = 0 To 2
CharName = Mid(UCase(UserName), i + 1, 1)
AscName = Asc(CharName)
If ((AscName >= 48) and (AscName <= 57)) or ((AscName >= 65) and (AscName
<=90)) Then
KeepName = KeepName + CStr(AscName)
End If
Next
RightName = Right(KeepName, 6)
TrimUserName = RightName
End Function

Function CreateDateAsNumber(ByVal NowID)
Dim i
Dim CharName
Dim AscName
Dim KeepName
Dim RightID
For i = 0 To 16
CharName = Mid(UCase(NowID), i + 1, 1)
AscName = Asc(CharName)
If ((AscName >= 48) and (AscName <= 57)) Then
KeepName = KeepName + CStr(CharName)
End If
Next
RightID = Right(KeepName, 6)
CreateDateAsNumber = RightID
End Function

'-------Online_Service_Request-Command Buttons-----------

Dim MyNameSpace

Function UpdateTicket_Click()
Item.Save
Call NotifyUser
End Function

Function ClosedBy_Click()
Set MyNameSpace = Application.GetNameSpace("MAPI")
Item.UserProperties.Find("ClosedBy").Value = MyNameSpace.CurrentUser
End Function

'-------------------Autofill Section---------------------

Dim strUserName ' UserName
Dim strRetCode ' Return Code of MAPI Logon
Dim strDeptName ' Department Name
Dim strDispName ' Display Name
Dim strCust1 ' Custom attribute field 1
Dim strCust2 ' Custom attribute field 2
Dim objSession ' MAPI Session
Dim objAddrEntries ' Current Object
Dim objFilter ' Address Entry Filter
Dim objDisplayName ' DisplayName
Dim objAddressEntry ' Current Address Entry

Set objInspector = Nothing
Set objAddrEntries = Nothing
Set objAddressEntry = Nothing

' MAPI property tags for the most common mailbox properties
Public Const CdoPR_MHS_COMMON_NAME = &H3A0F001E ' Offline Alias
Public Const CdoPR_DISPLAY_NAME = &H3001001E ' DisplayName
Public Const CdoPR_DEPARTMENT_NAME = &H3A18001E ' Department Name
'Public Const CdoPR_BUSINESS_TELEPHONE_NUMBER = &H3A08001E ' Phone and
Business phone

' Custom Attribute MAPI property tags
Public Const PR_EMS_AB_EXTENSION_ATTRIBUTE_1 = &H802D001E
Public Const PR_EMS_AB_EXTENSION_ATTRIBUTE_2 = &H802E001E
Public Const strServer = "MyServer"
Public Const strMailbox = "MyMailbox"

Function SetName_Click()
Set MyNameSpace = Application.GetNameSpace("MAPI")
Item.UserProperties.Find("Fullname").Value = MyNameSpace.Currentuser
Set strUserName = MyNameSpace.currentuser
' Create session
Set objSession = Application.CreateObject("MAPI.Session")
strRetCode = objSession.Logon(strUserName, "", False, False, 0)
' strRetCode =
objSession.Logon(Application.GetNameSpace("MAPI").CurrentUser, "", False,
False, 0)
' If strUserName not found
If Trim(strUserName) = "" Then
' Error creating session, show error message and exit
MsgBox "Undefinied error. Errorcode: " & strRetCode & ". Please contact
your System Administrator", 48, "Microsoft Outlook"
Item_Open = False
Else
strRetCode = "OK"
End If

' Set Subject (it looks better than <untitled>, or ?)
Item.Subject = "Online Service Request"
Set objAddrEntries = objSession.AddressLists("Global Address
List").AddressEntries
Set objFilter = objAddrEntries.Filter
objFilter.Fields.Add CdoPR_DISPLAY_NAME, strUserName
For Each objAddressEntry In objAddrEntries
On Error Resume Next
strDispName = objAddressEntry.Fields (CdoPR_DISPLAY_NAME).Value
strDeptName = objAddressEntry.Fields (CdoPR_DEPARTMENT_NAME).Value
strCust1 = objAddressEntry.Fields
(PR_EMS_AB_EXTENSION_ATTRIBUTE_1).Value
strCust2 = objAddressEntry.Fields
(PR_EMS_AB_EXTENSION_ATTRIBUTE_2).Value
Next

Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("FullName").Value
= strDispName
If Trim(strDeptName) <> "" Then
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("DepartmentName").Value
= strDeptName
End If
If Trim(strCust1) <> "" Then
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("DepartmentNumber").Value
= strCust1
End If
If Trim(strCust2) <> "" Then
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("PhoneExtension").Value
= strCust2
End If

End Function
'----------------------Printing Routine------------------------
Dim objWord
Dim strTemplate
Dim strField
Dim strField1
Dim objDoc
Dim objMark
Dim mybklist
Dim counter

Sub cmdPrint_Click()

Item.Save
Set objWord = CreateObject("Word.Application")

' Put the name of the Word template that contains the bookmarks
strTemplate = "OSR.dot"

' Location of Word template; could be on a shared LAN
strTemplate = "\\ivory\forms\" & strTemplate

Set objDoc = objWord.Documents.Add(strTemplate)
Set mybklist = objDoc.Bookmarks

For counter = 1 to mybklist.count
Set objMark = objDoc.Bookmarks(counter)
strField = objMark.Name
If strField = "SentField" then
strField1 = CStr(Item.SentOn)
ElseIf strField = True then
objDoc.FormFields(objMark.Name).CheckBox.Value = True
ElseIf strField = False then
objDoc.FormFields(objMark.Name).CheckBox.Value = False
Else
strField1 = Item.UserProperties(strField)
End If
objMark.Range.InsertBefore strField1
Next
msgbox "Printing to " & objWord.ActivePrinter
objDoc.PrintOut 0
objWord.Quit(0)
' Clean Up
' objDoc = Nothing
' objWord = Nothing
End Sub

'--------------Send Update to User---------------
Sub NotifyUser()
Dim myOlApp 'as New Outlook.Application
Dim myItem 'as Outlook.MailItem
Dim myNotify
Dim olMailItem
Dim myRecipient 'as Outlook.Recipient
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
strDispName =
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("FullName").Value
TicketID = Item.UserProperties.Find("TicketID").Value
Set myRecipient = myItem.Recipients.Add(strDispName)
' If myNotify.Updated Then
myItem.Subject = "Updates have occurred on your OSR, Ticket ID: " &
TicketID
myItem.Body = "To review the updates to your Help Desk Ticket, look in
Public Folders (Help Desk Queue)."
myItem.Display
myItem.Send
' End If
End Sub
'-------------------CDO Installation Routine---------------------

'Function IsCDOInstalled()
'Dim testCDOobj
' On Error Resume Next
' Set testCDOobj = Application.CreateObject("MAPI.Session")
' If Err.Number <> 0 Then
' IsCDOInstalled = False
' Else
' IsCDOInstalled = True
' end if
' If Not testCDOobj Is Nothing Then
' Set testCDOobj = Nothing
' End If
' Exit Function
'End Function

'Function InstallCDO()

'Dim blnSuccess
'Dim objInstaller
'Dim strProductId, strFeatureName
' On Error Resume Next
' Set objInstaller =
Application.CreateObject("WindowsInstaller.Installer")
' strProductId = Application.ProductCode
' strFeatureName = "OutlookCDO"
' If objInstaller.FeatureState(strProductId, strFeatureName) <> 3 Then
' objInstaller.ConfigureFeature strProductId, strFeatureName, 3
' If Err.Number <> 0 Then
' blnSuccess = False
' Else
' blnSuccess = True
' End If
' Else
' blnSuccess = True
' End If
' Install = blnSuccess
'End Function
Click to expand...
 
B

Bill Billmire

Sue, you are right, It's my understanding (or lack of) Outlook Property
Values. I'll re-read the chapter in your book on those concepts... Once I
inserted the correct [Item.UserProperties] values it worked without needed to
re-process anything. It just pulled the data from the existing Outlook Form
fields, as I wanted. Code below now works... From a code review
perspective, do you have any other suggestions/comments?

I "should" be setting the TicketID module-level variable only once, if I am
doing it twice - that's an error. Where do you see the second setting of
that variable?

Thanks,

Bill Billmire -

Sue Mosher said:
So you're not concerned about variables at all but about Outlook property
values? I'm confused now. I don't understand what you mean by "re-evaluate
variables" in your original post.

You are correct, though, that you would retrieve the values through the
UserProperties collection, preferably without Find:

Item.UserProperties("TicketID")

You should not be reading or setting control values unless they are unbound
controls. Use property values instead.

I also see that you have a TicketID module-level variable, but you set it at
least twice. Is there a reason for that?
--
Sue Mosher, Outlook MVP

Bill Billmire said:
Below is the code for the entire module. The two fields/variables I am
concerned with in the "Notify User" sub-routine are "Fullname" and
"TicketID". These fields (on the Outlook Form) will always be populated
on
the (Edit Read Page), so I should be able to just retrieve the data from
those fields [Right?]?


'-----------------OnLine Service Request-------------------
'----Code Updated on January 12 2005 by Bill Billmire----
'-----------Added Printing Routine (1/10/2005)------------
'---------Added Notify User Routine (1/12/2005)----------

Option Explicit

'----------Ticket ID & Window Size and Placement---------

Dim UserName
Dim Trimmed
Dim TicketID
Dim NowID
Dim MyDate
Dim objInspector ' Inspector object

Sub Item_Open()
If Item.CreationTime = #1/1/4501# Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 485
Set objInspector = Nothing
ElseIf Item.Size <> 0 Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 665
Set objInspector = Nothing
End If
If (Item.SenderName = "") Then
UserName = Application.GetNameSpace("MAPI").CurrentUser
Trimmed = TrimUserName(UserName)
NowID = Now
MyDate = CreateDateAsNumber(NowID)
TicketID = Trimmed & MyDate
Item.UserProperties.Find("TicketID").Value = TicketID
End If
End Sub
Function TrimUserName(ByVal UserName)

Dim CharName
Dim AscName
Dim KeepName
Dim RightName
Dim i
KeepName = ""

For i = 0 To 2
CharName = Mid(UCase(UserName), i + 1, 1)
AscName = Asc(CharName)
If ((AscName >= 48) and (AscName <= 57)) or ((AscName >= 65) and (AscName
<=90)) Then
KeepName = KeepName + CStr(AscName)
End If
Next
RightName = Right(KeepName, 6)
TrimUserName = RightName
End Function

Function CreateDateAsNumber(ByVal NowID)
Dim i
Dim CharName
Dim AscName
Dim KeepName
Dim RightID
For i = 0 To 16
CharName = Mid(UCase(NowID), i + 1, 1)
AscName = Asc(CharName)
If ((AscName >= 48) and (AscName <= 57)) Then
KeepName = KeepName + CStr(CharName)
End If
Next
RightID = Right(KeepName, 6)
CreateDateAsNumber = RightID
End Function

'-------Online_Service_Request-Command Buttons-----------

Dim MyNameSpace

Function UpdateTicket_Click()
Item.Save
Call NotifyUser
End Function

Function ClosedBy_Click()
Set MyNameSpace = Application.GetNameSpace("MAPI")
Item.UserProperties.Find("ClosedBy").Value = MyNameSpace.CurrentUser
End Function

'-------------------Autofill Section---------------------

Dim strUserName ' UserName
Dim strRetCode ' Return Code of MAPI Logon
Dim strDeptName ' Department Name
Dim strDispName ' Display Name
Dim strCust1 ' Custom attribute field 1
Dim strCust2 ' Custom attribute field 2
Dim objSession ' MAPI Session
Dim objAddrEntries ' Current Object
Dim objFilter ' Address Entry Filter
Dim objDisplayName ' DisplayName
Dim objAddressEntry ' Current Address Entry

Set objInspector = Nothing
Set objAddrEntries = Nothing
Set objAddressEntry = Nothing

' MAPI property tags for the most common mailbox properties
Public Const CdoPR_MHS_COMMON_NAME = &H3A0F001E ' Offline Alias
Public Const CdoPR_DISPLAY_NAME = &H3001001E ' DisplayName
Public Const CdoPR_DEPARTMENT_NAME = &H3A18001E ' Department Name
'Public Const CdoPR_BUSINESS_TELEPHONE_NUMBER = &H3A08001E ' Phone and
Business phone

' Custom Attribute MAPI property tags
Public Const PR_EMS_AB_EXTENSION_ATTRIBUTE_1 = &H802D001E
Public Const PR_EMS_AB_EXTENSION_ATTRIBUTE_2 = &H802E001E
Public Const strServer = "MyServer"
Public Const strMailbox = "MyMailbox"

Function SetName_Click()
Set MyNameSpace = Application.GetNameSpace("MAPI")
Item.UserProperties.Find("Fullname").Value = MyNameSpace.Currentuser
Set strUserName = MyNameSpace.currentuser
' Create session
Set objSession = Application.CreateObject("MAPI.Session")
strRetCode = objSession.Logon(strUserName, "", False, False, 0)
' strRetCode =
objSession.Logon(Application.GetNameSpace("MAPI").CurrentUser, "", False,
False, 0)
' If strUserName not found
If Trim(strUserName) = "" Then
' Error creating session, show error message and exit
MsgBox "Undefinied error. Errorcode: " & strRetCode & ". Please contact
your System Administrator", 48, "Microsoft Outlook"
Item_Open = False
Else
strRetCode = "OK"
End If

' Set Subject (it looks better than <untitled>, or ?)
Item.Subject = "Online Service Request"
Set objAddrEntries = objSession.AddressLists("Global Address
List").AddressEntries
Set objFilter = objAddrEntries.Filter
objFilter.Fields.Add CdoPR_DISPLAY_NAME, strUserName
For Each objAddressEntry In objAddrEntries
On Error Resume Next
strDispName = objAddressEntry.Fields (CdoPR_DISPLAY_NAME).Value
strDeptName = objAddressEntry.Fields (CdoPR_DEPARTMENT_NAME).Value
strCust1 = objAddressEntry.Fields
(PR_EMS_AB_EXTENSION_ATTRIBUTE_1).Value
strCust2 = objAddressEntry.Fields
(PR_EMS_AB_EXTENSION_ATTRIBUTE_2).Value
Next

Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("FullName").Value
= strDispName
If Trim(strDeptName) <> "" Then
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("DepartmentName").Value
= strDeptName
End If
If Trim(strCust1) <> "" Then
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("DepartmentNumber").Value
= strCust1
End If
If Trim(strCust2) <> "" Then
Item.GetInspector.ModifiedFormPages("Online_Service_Request").Controls("PhoneExtension").Value
= strCust2
End If

End Function
'----------------------Printing Routine------------------------
Dim objWord
Dim strTemplate
Dim strField
Dim strField1
Dim objDoc
Dim objMark
Dim mybklist
Dim counter

Sub cmdPrint_Click()

Item.Save
Set objWord = CreateObject("Word.Application")

' Put the name of the Word template that contains the bookmarks
strTemplate = "OSR.dot"

' Location of Word template; could be on a shared LAN
strTemplate = "\\ivory\forms\" & strTemplate

Set objDoc = objWord.Documents.Add(strTemplate)
Set mybklist = objDoc.Bookmarks

For counter = 1 to mybklist.count
Set objMark = objDoc.Bookmarks(counter)
strField = objMark.Name
If strField = "SentField" then
strField1 = CStr(Item.SentOn)
ElseIf strField = True then
objDoc.FormFields(objMark.Name).CheckBox.Value = True
ElseIf strField = False then
objDoc.FormFields(objMark.Name).CheckBox.Value = False
Else
strField1 = Item.UserProperties(strField)
End If
objMark.Range.InsertBefore strField1
Next
msgbox "Printing to " & objWord.ActivePrinter
objDoc.PrintOut 0
objWord.Quit(0)
' Clean Up
' objDoc = Nothing
' objWord = Nothing
End Sub

'--------------Send Update to User---------------
Sub NotifyUser()
Dim myOlApp 'as New Outlook.Application
Dim myItem 'as Outlook.MailItem
Dim myNotify
Dim olMailItem
Dim myRecipient 'as Outlook.Recipient
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
Set myRecipient = myItem.Recipients.Add((Item.UserProperties("FullName"))
myItem.Subject = "Updates have occurred on your OSR, Ticket ID: " &
Item.UserProperties("TicketID")
myItem.Body = "To review the updates to your Help Desk Ticket, look in
Public Folders (Help Desk Queue)."
myItem.Display
myItem.Send
End Sub
'-------------------CDO Installation Routine---------------------

'Function IsCDOInstalled()
'Dim testCDOobj
' On Error Resume Next
' Set testCDOobj = Application.CreateObject("MAPI.Session")
' If Err.Number <> 0 Then
' IsCDOInstalled = False
' Else
' IsCDOInstalled = True
' end if
' If Not testCDOobj Is Nothing Then
' Set testCDOobj = Nothing
' End If
' Exit Function
'End Function

'Function InstallCDO()

'Dim blnSuccess
'Dim objInstaller
'Dim strProductId, strFeatureName
' On Error Resume Next
' Set objInstaller =
Application.CreateObject("WindowsInstaller.Installer")
' strProductId = Application.ProductCode
' strFeatureName = "OutlookCDO"
' If objInstaller.FeatureState(strProductId, strFeatureName) <> 3 Then
' objInstaller.ConfigureFeature strProductId, strFeatureName, 3
' If Err.Number <> 0 Then
' blnSuccess = False
' Else
' blnSuccess = True
' End If
' Else
' blnSuccess = True
' End If
' Install = blnSuccess
'End Function
Click to expand...
Click to expand...
 
S

Sue Mosher [MVP-Outlook]

I must have become confused looking at two different code samples. Now I see
TicketID only once, in Item_Open.

One other suggestion: You don't need to supply a logon name for CDO since
you're piggybacking on the current Outlook session. You can use:

objSession.Logon("", "", False, False)
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Change Reply to Recipient Address for an Action In an Email Message 0
Remove Meeting from Sender's Calendar with VBA 1
How to add a bcc recipient to the current email item 10
Problem with saving a mail with a lot of recipients 4
On Closing Outlook after Programmatically Sending Email, Word Promptsto Save 3
Sending message with multiple SMTP BCCs 2
how to disable security message in save attachments macro "A programis trying to access e-mail addre 5
Setting the Reminder flag in VBA for e-Mails sent to users 5

Top