OLK2K3: Programmatically sending message(s) to recipient.

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

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
 
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.
 
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
 
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...
 
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...
 
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)
 
Back
Top