OLK2K3: "Read page" code not firing when opening or clicking cmdBu

B

Bill Billmire

I have a working form (both Edit Compose Page and Edit Read Page). I made
some changes to the code and now the code fires correctly on the "Edit
Compose Page", but does nothing on the "Edit Read Page". I inserted [Msgbox
"got here"] lines to determine where the script blows-up, but it never fires
at all on the Edit Read Page. Code below... I was trying to add the
"printing" routine toward the end, that is currently commented out...
Ideas/suggestions/comments?

Option Explicit

'--------------------Ticket ID-----------------------

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

Sub Item_Open()
msgbox "got here"
If Item.CreationTime <> #1/1/4501# Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 650
Set objInspector = Nothing
Else
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 630
objInspector.Top = 0
objInspector.Height = 480
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
msgbox "got here"
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 strTemplate
'Dim objWord
'Dim objDocs
'Dim PageRange
'Dim strField
'Dim strField1

'Function cmdPrint_Click()

' Set objWord = CreateObject("Word.Application")

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

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

' Set objDocs = objWord.Documents
' objDocs.Add strTemplate
' set mybklist = objWord.ActiveDocument.Bookmarks


' For counter = 1 to mybklist.count
' strField = objWord.ActiveDocument.Bookmarks(counter)
' objWord.ActiveDocument.Bookmarks(strField).Select
' strField1 = Item.UserProperties.find(strField).value
' If strField1 = True then
' strField1 = "Yes"
' ElseIf strField1 = False then
' strField1 = "No "
' End If
' objWord.Selection.TypeText Cstr(strField1)
' Next
' objWord.PrintOut Background = True
' objWord.Quit(0)

'End Function
 
S

Sue Mosher [MVP-Outlook]

Where is the form published?

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Bill Billmire said:
I have a working form (both Edit Compose Page and Edit Read Page). I made
some changes to the code and now the code fires correctly on the "Edit
Compose Page", but does nothing on the "Edit Read Page". I inserted
[Msgbox
"got here"] lines to determine where the script blows-up, but it never
fires
at all on the Edit Read Page. Code below... I was trying to add the
"printing" routine toward the end, that is currently commented out...
Ideas/suggestions/comments?

Option Explicit

'--------------------Ticket ID-----------------------

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

Sub Item_Open()
msgbox "got here"
If Item.CreationTime <> #1/1/4501# Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 650
Set objInspector = Nothing
Else
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 630
objInspector.Top = 0
objInspector.Height = 480
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
msgbox "got here"
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 strTemplate
'Dim objWord
'Dim objDocs
'Dim PageRange
'Dim strField
'Dim strField1

'Function cmdPrint_Click()

' Set objWord = CreateObject("Word.Application")

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

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

' Set objDocs = objWord.Documents
' objDocs.Add strTemplate
' set mybklist = objWord.ActiveDocument.Bookmarks


' For counter = 1 to mybklist.count
' strField = objWord.ActiveDocument.Bookmarks(counter)
' objWord.ActiveDocument.Bookmarks(strField).Select
' strField1 = Item.UserProperties.find(strField).value
' If strField1 = True then
' strField1 = "Yes"
' ElseIf strField1 = False then
' strField1 = "No "
' End If
' objWord.Selection.TypeText Cstr(strField1)
' Next
' objWord.PrintOut Background = True
' objWord.Quit(0)

'End Function
Click to expand...
 
B

Bill Billmire

I published the "updated" form to both 'Personal Forms Library' (as a testing
location) and the 'Organizational Forms Library'. The "Read Page" code never
fires, in either location???

Thanks in advance.

Bill Billmire -
(e-mail address removed)

Sue Mosher said:
Where is the form published?

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Bill Billmire said:
I have a working form (both Edit Compose Page and Edit Read Page). I made
some changes to the code and now the code fires correctly on the "Edit
Compose Page", but does nothing on the "Edit Read Page". I inserted
[Msgbox
"got here"] lines to determine where the script blows-up, but it never
fires
at all on the Edit Read Page. Code below... I was trying to add the
"printing" routine toward the end, that is currently commented out...
Ideas/suggestions/comments?

Option Explicit

'--------------------Ticket ID-----------------------

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

Sub Item_Open()
msgbox "got here"
If Item.CreationTime <> #1/1/4501# Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 650
Set objInspector = Nothing
Else
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 630
objInspector.Top = 0
objInspector.Height = 480
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
msgbox "got here"
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 strTemplate
'Dim objWord
'Dim objDocs
'Dim PageRange
'Dim strField
'Dim strField1

'Function cmdPrint_Click()

' Set objWord = CreateObject("Word.Application")

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

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

' Set objDocs = objWord.Documents
' objDocs.Add strTemplate
' set mybklist = objWord.ActiveDocument.Bookmarks


' For counter = 1 to mybklist.count
' strField = objWord.ActiveDocument.Bookmarks(counter)
' objWord.ActiveDocument.Bookmarks(strField).Select
' strField1 = Item.UserProperties.find(strField).value
' If strField1 = True then
' strField1 = "Yes"
' ElseIf strField1 = False then
' strField1 = "No "
' End If
' objWord.Selection.TypeText Cstr(strField1)
' Next
' objWord.PrintOut Background = True
' objWord.Quit(0)

'End Function
Click to expand...
Click to expand...
 
S

Sue Mosher [MVP-Outlook]

Did you leave the "send form definition with item" box on the (Properties)
page unchecked?

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Bill Billmire said:
I published the "updated" form to both 'Personal Forms Library' (as a
testing
location) and the 'Organizational Forms Library'. The "Read Page" code
never
fires, in either location???
I have a working form (both Edit Compose Page and Edit Read Page). I
made
some changes to the code and now the code fires correctly on the "Edit
Compose Page", but does nothing on the "Edit Read Page". I inserted
[Msgbox
"got here"] lines to determine where the script blows-up, but it never
fires
at all on the Edit Read Page. Code below... I was trying to add the
"printing" routine toward the end, that is currently commented out...
Ideas/suggestions/comments?

Option Explicit

'--------------------Ticket ID-----------------------

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

Sub Item_Open()
msgbox "got here"
If Item.CreationTime <> #1/1/4501# Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 650
Set objInspector = Nothing
Else
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 630
objInspector.Top = 0
objInspector.Height = 480
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
msgbox "got here"
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 strTemplate
'Dim objWord
'Dim objDocs
'Dim PageRange
'Dim strField
'Dim strField1

'Function cmdPrint_Click()

' Set objWord = CreateObject("Word.Application")

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

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

' Set objDocs = objWord.Documents
' objDocs.Add strTemplate
' set mybklist = objWord.ActiveDocument.Bookmarks


' For counter = 1 to mybklist.count
' strField = objWord.ActiveDocument.Bookmarks(counter)
' objWord.ActiveDocument.Bookmarks(strField).Select
' strField1 = Item.UserProperties.find(strField).value
' If strField1 = True then
' strField1 = "Yes"
' ElseIf strField1 = False then
' strField1 = "No "
' End If
' objWord.Selection.TypeText Cstr(strField1)
' Next
' objWord.PrintOut Background = True
' objWord.Quit(0)

'End Function
Click to expand...
Click to expand...
Click to expand...
 
B

Bill Billmire

Thanks, Sue your awesome!

I went back into your previous response and reviewed all settings,
properties and publication locations... The problem was resolved by
(deleting and re-publishing the form) in the Organizational Forms Library.
Maybe a server replication hiccup?!?
Anyway, the code now fires on both Edit Compose Page and Edit Read Pages.

Now that the code is executing on the "read" page I can code & debug the
print function that I was initially trying to implement (see code below). I
will create another post for questions and issues dealing with that aspect.

Thanks,

Bill Billmire -

Sue Mosher said:
Did you leave the "send form definition with item" box on the (Properties)
page unchecked?

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Bill Billmire said:
I published the "updated" form to both 'Personal Forms Library' (as a
testing
location) and the 'Organizational Forms Library'. The "Read Page" code
never
fires, in either location???
I have a working form (both Edit Compose Page and Edit Read Page). I
made
some changes to the code and now the code fires correctly on the "Edit
Compose Page", but does nothing on the "Edit Read Page". I inserted
[Msgbox
"got here"] lines to determine where the script blows-up, but it never
fires
at all on the Edit Read Page. Code below... I was trying to add the
"printing" routine toward the end, that is currently commented out...
Ideas/suggestions/comments?

Option Explicit

'--------------------Ticket ID-----------------------

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

Sub Item_Open()
msgbox "got here"
If Item.CreationTime <> #1/1/4501# Then
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 640
objInspector.Top = 0
objInspector.Height = 650
Set objInspector = Nothing
Else
Set objInspector = Item.GetInspector
objInspector.Left = 0
objInspector.Width = 630
objInspector.Top = 0
objInspector.Height = 480
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
msgbox "got here"
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 strTemplate
'Dim objWord
'Dim objDocs
'Dim PageRange
'Dim strField
'Dim strField1

'Function cmdPrint_Click()

' Set objWord = CreateObject("Word.Application")

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

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

' Set objDocs = objWord.Documents
' objDocs.Add strTemplate
' set mybklist = objWord.ActiveDocument.Bookmarks


' For counter = 1 to mybklist.count
' strField = objWord.ActiveDocument.Bookmarks(counter)
' objWord.ActiveDocument.Bookmarks(strField).Select
' strField1 = Item.UserProperties.find(strField).value
' If strField1 = True then
' strField1 = "Yes"
' ElseIf strField1 = False then
' strField1 = "No "
' End If
' objWord.Selection.TypeText Cstr(strField1)
' Next
' objWord.PrintOut Background = True
' objWord.Quit(0)

'End Function
Click to expand...
Click to expand...
Click to expand...
 

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

Custom Form not working on new term server 3
OLK2K3: Programmatically sending message(s) to recipient. 5
SLOOOOW... retrieval with ADO 0
File not found when opening 3
Opening a Word document or template from Access 0
Read-only code for public folder items to prevent conflicts 3
Audit Trail Code Not Using All Audit Types 1

Top