'Selecting Contacts from a Multi-select List Box VB Script Code
'Works with Outlook 98 or 2000
'Written by Helen Feddema 11-14-1999
'Last modified 5-2-2001

Dim nms
Dim fld
Dim itms
Dim itm
Dim myitm
Dim pg
Dim ctls
Dim ctlFolder
Dim appWord
Dim AppOutlook
Dim varContactArray()
Dim cboLetters
Dim cboCategory
Dim lstContacts
Dim strWordTemplate
Dim fso
Dim strTest
Dim fLetterCreated
Dim i
Dim Ritems
Const olContacts = 10
Const olInbox = 6
Const wdDocumentsPath = 0
Const wdUserTemplatesPath = 2
Const wdProgramPath = 9

Function Item_Open()

	Set AppOutlook = Item.Application
	Set itm = Item.GetInspector
	Set pgs = itm.ModifiedFormPages
	Set pg = pgs("Select Contacts")
	Set ctls = pg.Controls
	Set ctlCategory = ctls("txtCategory")
	Set lstContacts = ctls("lstContacts")
	Set ctlFolder = ctls("txtFolder")
	ctlFolder.Value = "[Default Inbox Folder]"

End Function
	Set AppOutlook = Nothing
	Set itm = Nothing
	Set pgs = Nothing
	Set pg = Nothing
	Set ctls = Nothing
	Set ctlCategory = Nothing
	Set lstContacts = Nothing
	Set ctlFolder = Nothing
	Set nms = Nothing
	Set fso = Nothing
	Set Ritems = Nothing

Function Item_Close()


End Function


Sub cmdSetFolder_Click()

	Dim fMessageFolder

	'MsgBox "We are in cmdSetFolder click subroutine"

	Set nms = Application.GetNameSpace("MAPI")
	fMessageFolder = False

	Do While fMessageFolder = False
		On Error Resume Next
		Set fld = nms.PickFolder
		If fld Is Nothing Then 
			MsgBox "Please select a folder"
			Exit Sub
		ElseIf fld.DefaultItemType <> 0 Then
			MsgBox "Selected folder does not contain mail itemss; please select another folder"
		Else
			fMessageFolder = True
		End If
	Loop

	ctlFolder.Value = fld.Name

End Sub


Sub cmdFill_List_Click()

	Dim strCategory
	Dim strCurrentContactName
	Dim strPrevContactName
	Dim intCount
	Dim strRow
	Dim AlreadyDone

	AlreadyDone = "MHT File Created"
'	Set itm = Item.GetInspector
'	Set nms = Application.GetNameSpace("MAPI")
	'MsgBox "Folder to process: " & ctlFolder.Value

	If ctlFolder.Value = "" Or ctlFolder.Value _
		= "[Default Inbox Folder]" Then
		Set fld = nms.GetDefaultFolder(6)
	End If

	Set itms = fld.Items
	strCategory = pg.Controls("txtCategory").Value

	If strCategory = "" Then strCategory = "SharePoint"

	strMatch = "[Categories] = " & Chr(39) & strCategory & Chr(39) & " And ( [BillingInformation] <> "  & Chr(39) & AlreadyDone & Chr(39) & ")"

'	MsgBox "Match string: " & strMatch

	Set Ritems = itms.Restrict(strMatch)

	lngCount = Ritems.Count

	If lngCount = 0 Then
		MsgBox "No Messages to add to listbox"

		Exit Sub
	Else
		'MsgBox lngCount & " messages to add to listbox"
	End If

'	Exit Sub

	strPrevContactName = ""
	ReDim varContactArray(lngCount - 1, 3)

	i = 0
	For Each itm In Ritems
		'Check that item is a message item and has a Non-empty subject, and skip otherwise
		If itm.Class = 43 Then
			If itm.Subject <> "" AND itm.BillingInformation <> "MHT File Created" Then

					varContactArray(i, 1) = itm.Subject
					varContactArray(i, 2) = ""
					i = i + 1
				
			End If

		End If
	Next

	'Leaving the width blank for the 2nd column makes it just the right size to display its data
	'lstContacts.ColumnWidths = "0 pt; ;0 pt"
	lstContacts.Width = 350
	lstContacts.List() = varContactArray
'	MsgBox "All messages added to drop-down list"

End Sub


Sub cmdLetters_Click

	Dim intRows
	Dim J
	Dim Imax 

	fLetterCreated = False
	intRows = Ritems.count

	'Check that a Word template has been selected
	Set cboLetters = ctls("cboLetters")
	strWordTemplate = cboLetters.Value
	If Len(strWordTemplate) < 2 Then
		MsgBox "Please select a Word template"
		Exit Sub
	End If

	'Open Word invisibly, using current Word instance if available
	On Error Resume Next
 	Set appWord = GetObject(, "Word.Application")
	If Err = 429 Then 
		Set appWord = Item.Application.CreateObject("Word.Application")
		Err = 0
	End If
 
	'Get paths from Word
	strDocsPath = appWord.Options.DefaultFilePath(wdDocumentsPath ) & "\"
	'MsgBox "Docs Path: " & strDocsPath
	strTemplatePath = appWord.Options.DefaultFilePath(wdUserTemplatesPath ) & "\"
	'MsgBox "Template Path: " & strTemplatePath
	strWordTemplate = strTemplatePath & strWordTemplate
	'MsgBox "Selected template: " & strWordTemplate

	'Check for existence of template in template folder,
	'and exit if not found
	Set fso = CreateObject("Scripting.FileSystemObject")
	
	'If file is not found, a "File not found" error is raised and the
	'code stops (Outlook VBS doesn't support real error handling)
	strTest = fso.GetFile(strWordTemplate)

	Imax = Ritems.Count

	For i = Imax to 1 Step -1

	   Set myItm = Ritems(i)
	   Call PrintDocs(myitm,strWordTemplate)

	Next

	If fLetterCreated = False Then
		MsgBox "No letters created; closing Word instance"
		
	End If

	appWord.Quit

End Sub


Function PrintDocs(o_item,strWordTemplate)

	dim strSaveName
	dim strMailAddr
	dim myMailItem
	dim myRecip
	dim nyAttach
	dim strDirpath
	dim strCat
	Dim MyDoc
	Dim MyBIProps
	Dim TitleProp
	Dim SubjectProp
	Dim strSubject
	Dim strPos
	Dim strFileName
	Dim FirstChar

	'MsgBox "We are in PrintDocs - VBScript"

	'Check that a Category has been selected
	strCat = ctlCategory.value

	'MsgBox "strCat = " & strCat

	Select Case strCat
	Case "FrontPage"
		strDirpath = "C:\3_FrontPage\"
		strMailAddr = "2_PosttoFrontPageTips@OutlookByTheSound.com"

	Case "SharePoint"
		strDirpath = "C:\3_SharePoint\"
		strMailAddr = "2_PosttoSharePointTips@OutlookByTheSound.com"

	Case "Outlook"
		strDirpath = "C:\3_Outlook\"
		strMailAddr = "2_PosttoOutlookTips@OutlookByTheSound.com"

	Case "SmallBiz"
		strDirpath = "C:\3_SBS\"
		strMailAddr = "2_PosttoSBSTips@OutlookByTheSound.com"

	Case "WUS"
		strDirpath = "C:\3_WUS\"
		strMailAddr = "2_PosttoWUSTips@OutlookByTheSound.com"

	End Select

	'Open a new letter based on the selected template
	appWord.Documents.Add strWordTemplate
	appWord.Visible = True
	Set MyDoc = appWord.ActiveDocument

	MyDoc.Content.InsertAfter o_item.Body

	strSubject = o_item.Subject

	strSubject = Replace(strSubject, """", "")
'	MsgBox "1strSubject = " & strSubject
	
	strSubject = Right(strSubject, Len(strSubject) - 5 )
'	MsgBox "2strSubject = " & strSubject

'	Set Title and Topic properties to strSubject
	'Write information to Word custom document properties
	'Set prps = appWord.ActiveDocument.CustomDocumentProperties

	Set MyBIProps = MyDoc.BuiltInDocumentProperties

	Set TitleProp = MyBIProps("Title")
	TitleProp.Value = strSubject

	Set SubjectProp = MyBIProps("Subject")
	SubjectProp.Value = strSubject

	strFileName = strSubject
	strFileName = Replace(strFileName, ".", "")
	strFileName = Replace(strFileName, ",", "")
	strFileName = Replace(strFileName, "\", "")
	strFileName = Replace(strFileName, " ", "_")
	strFileName = Replace(strFileName, ":", "")
	strFileName = Replace(strFileName, "(", "")
	strFileName = Replace(strFileName, ")", "")
	
	strFileName = Left(strFileName, 50)

	strSaveName = strDirPath & strFileName & ".mht"

	'MsgBox "FilePathName = " & strSaveName

	o_item.Mileage = "XML File Created"
	o_item.BillingInformation = "MHT File Created"
 	o_item.Save

	fLetterCreated = True

	MyDoc.SaveAs strSaveName, 9

'Create the message, attachment, and send it
	Set myMailItem = AppOutlook.CreateItem(0)
        myMailItem.Subject = strSubject
        myMailItem.Body = "Message with attachment for Exchange PF and SharePoint"
        Set myRecip = myMailItem.Recipients.Add(strMailAddr)
	  Set nyAttach = myMailItem.Attachments.Add(strSaveName)
        myMailItem.Send

	MyDoc.close

	Set MyBIProps = Nothing
	Set TitleProp = Nothing
	Set SubjectProp = Nothing	
	Set MyDoc = Nothing
	Set myRecip = Nothing
      Set myMailItem = Nothing
	Set nyAttach = Nothing
	
End Function

   