Outlook Technologies

Outlook Forms

Languages

Samples

More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 09-Sep-2010 05:59

Looking for help with Outlook programming projects — VSTO, add-ins, VBA, custom Outlook forms, etc.? You′ve come to the right place!

NEW! >> Subscribe to this site via RSS. For more RSS options, see the complete list of feeds on our main news page.

Code level: intermediate Code area: Outlook Form Design Printer Friendly Version
Title: Outlook Survey Response Accumulation/Reporting
Description: Accumulates and reports results of an Outlook survey that uses the survey code at http://www.outlookcode.com/d/forms/survey.htm, with only slight modification (described below in the code section). The person running the compliation code only needs to : 1) Edit the code below to specify the number of questions and type of each question (Yes/No, Agree scale, Text, Choice, Rating); 2) If using any "Choices" questions, specify the actual choice strings in the code, and add new variables as needed (full instructions are given in the code). 3) Accumulate the survey responses in a folder called "Survey Responses" in their Inbox (the name of the folder is configurable in the code).
Date: 04-Jun-2004 04:44
Code level: intermediate
Code area: Outlook Form Design
Posted by: Matthew Bell
Body: 'change these two lines in the original survey code -- from ' myresponse.Body = myresponse.Body & "CSV Format: " & Chr(13) 'to ' myresponse.Body = myresponse.Body & "Pipe-delimited Format: " & Chr(13) 'and from ' strcsvanswers = strcsvanswers & Chr(34) & aryAnswers(I) & Chr(34) & "," 'to ' strcsvanswers = strcsvanswers & Chr(34) & aryAnswers(I) & Chr(34) & "\| ' 'Code: Sub CompileSurveyResults() 'CompileSurveyResults.vbs 'Created by: Matthew Bell 'Date: 5/10/04 'Last Revised: by Matthew Bell 6/3/04 ' Idea behind this code is in one shot to account for all possible number & types of questions ' that a survey might ask, utilitizing the survey form at http://www.outlookcode.com/d/forms/survey.htm. ' I think it's complete, except for the report formatting of the answers to "Choice"-type questions at the end. ' ' Const ForReading = 1, ForWriting = 2, ForAppending = 8 Dim bGotQuestionText Dim sSurveyAnswersFolder Dim iNumQuestions, sQType(), sQDescr(), iQCtr Dim iCtr Dim iStrDisagree(), iDisagree(), iNeutral(), iAgree(), iStrAgree() Dim sText() Dim iYes(), iNo(), iNA() Dim i1(), i2(), i3(), i4(), i5(), i6(), i7(), i8(), i9(), i10() Dim sChoice1, iChoice1() Dim sChoice2, iChoice2() Dim sChoice3, iChoice3() Dim sChoice4, iChoice4() Dim sChoice5, iChoice5() Dim sChoice11, iChoice11() Dim sChoice12, iChoice12() Dim sChoice13, iChoice13() Dim sChoice14, iChoice14() Dim iNotAnswered() Dim oSession As MAPI.Session Dim oSurveyMsgs As MAPI.Messages Dim oMsg As MAPI.Message Dim FSO Dim iLineCtr, iTotalLines, sDummy Dim oMsgTextFile Dim sTempMsgFilename Dim sMsgText() Dim sQuestionText() Dim sFullAnswer() Dim sAnswerPieces Dim aDummyArray Dim iOnCurrentAnswer Dim iNumAnswerPieces Dim iACtr Dim bGotGoodFilenameAndPath Dim sFnAndPath Dim oResultsTextFile Dim sReportTitle Dim sWord '************************************************************************** ' I M P O R T A N T - - - A D M I N - C O N F I G U R E D V A R I A B L E S '************************************************************************ 'admin-configured variables regarding questions that were in survey sSurveyAnswersFolder = "Survey Responses" 'a folder within the Inbox of the person running the code iNumQuestions = 7 ReDim sQType(1 + iNumQuestions) sQType(1) = "A" 'Agree Scale sQType(2) = "A" 'Agree Scale sQType(3) = "A" 'Agree Scale sQType(4) = "A" 'Agree Scale sQType(5) = "T" 'Text sQType(6) = "T" 'Text sQType(7) = "T" 'Text ' Range of possibilities: 'sQType(1) = "A" 'Agree Scale 'sQType(2) = "T" 'Text 'sQType(3) = "Y" 'Yes/No/NA 'sQType(4) = "R" 'Rating of 1 - 10 'sQType(5) = "C" 'Configured choices 'if using "Configured Choices", then specify what the choices/options are so that ' they can be accurately reported. If using more than one "Choice" question, ' then "Dim" more variables above, assign them their labels here, ReDim them below, ' and add options to accumulate totals in the Select Case statement at the end. ' For instance, Question 1 might have variable/answer pairs like: 'sChoice1 = "Chocolate" 'sChoice2 = "Vanilla" 'sChoice3 = "Strawberry" 'sChoice4 = "Pumpkin Pie" 'sChoice5 = "Bubble Gum" ' while Question 2 would have different variables assigned to its answers: 'sChoice11 = "North" 'sChoice12 = "South" 'sChoice13 = "East" 'sChoice14 = "West" sTempMsgFilename = "C:\TempMsgFile!!.txt" '************************************************************************ '**************************** 'INITIALIZE ALL VARIABLES '**************************** 'set all arrays to number of questions above ' (the "1 + " accounts for the 0th array item, ' so that Question 1 can be array item 1 ReDim sQDescr(1 + iNumQuestions) ReDim iStrDisagree(1 + iNumQuestions) ReDim iDisagree(1 + iNumQuestions) ReDim iNeutral(1 + iNumQuestions) ReDim iAgree(1 + iNumQuestions) ReDim iStrAgree(1 + iNumQuestions) ReDim iAgree(1 + iNumQuestions) ReDim sText(1 + iNumQuestions) ReDim iYes(1 + iNumQuestions) ReDim iNo(1 + iNumQuestions) ReDim iNA(1 + iNumQuestions) ReDim i1(1 + iNumQuestions) ReDim i2(1 + iNumQuestions) ReDim i3(1 + iNumQuestions) ReDim i4(1 + iNumQuestions) ReDim i5(1 + iNumQuestions) ReDim i6(1 + iNumQuestions) ReDim i7(1 + iNumQuestions) ReDim i8(1 + iNumQuestions) ReDim i9(1 + iNumQuestions) ReDim i10(1 + iNumQuestions) ReDim sChoice(1 + iNumQuestions) ReDim iChoice1(1 + iNumQuestions) ReDim iChoice2(1 + iNumQuestions) ReDim iChoice3(1 + iNumQuestions) ReDim iChoice4(1 + iNumQuestions) ReDim iChoice5(1 + iNumQuestions) ReDim iChoice11(1 + iNumQuestions) ReDim iChoice12(1 + iNumQuestions) ReDim iChoice13(1 + iNumQuestions) ReDim iChoice14(1 + iNumQuestions) ReDim iNotAnswered(1 + iNumQuestions) ReDim sQuestionText(1 + iNumQuestions) ReDim sFullAnswer(1 + iNumQuestions) 'ReDim sAnswerPieces(1 + iNumQuestions) For iQCtr = 1 To iNumQuestions iNotAnswered(iQCtr) = 0 Select Case sQType(iQCtr) Case "A" sQDescr(iQCtr) = "Agree Scale: " iStrDisagree(iQCtr) = 0 iDisagree(iQCtr) = 0 iNeutral(iQCtr) = 0 iAgree(iQCtr) = 0 iStrAgree(iQCtr) = 0 Case "T" sQDescr(iQCtr) = "Text: " sText(iQCtr) = Null Case "Y" sQDescr(iQCtr) = "Y/N: " iYes(iQCtr) = 0 iNo(iQCtr) = 0 iNA(iQCtr) = 0 Case "R" sQDescr(iQCtr) = "1-10: " i1(iQCtr) = 0 i2(iQCtr) = 0 i3(iQCtr) = 0 i4(iQCtr) = 0 i5(iQCtr) = 0 i6(iQCtr) = 0 i7(iQCtr) = 0 i8(iQCtr) = 0 i9(iQCtr) = 0 i10(iQCtr) = 0 Case "C" sQDescr(iQCtr) = "Choice: " iChoice1(iQCtr) = 0 iChoice2(iQCtr) = 0 iChoice3(iQCtr) = 0 iChoice4(iQCtr) = 0 iChoice5(iQCtr) = 0 iChoice11(iQCtr) = 0 iChoice12(iQCtr) = 0 iChoice13(iQCtr) = 0 iChoice14(iQCtr) = 0 Case Else MsgBox "Configuration error likely in admin-configured variables -- encountered " & _ "in variable initialization section. sQType(" & iQCtr & ") = " & sQType(iQCtr) & "." End Select sQuestionText(iQCtr) = Null Next 'QCtr '************************************** 'GET TEXT FROM EACH MESSAGE INTO VARIABLES '************************************** 'look for messages in the Inbox folder specified above Set oSession = CreateObject("MAPI.Session") oSession.Logon NewSession:=False Set oSurveyMsgs = oSession.Inbox.Folders(sSurveyAnswersFolder).Messages If oSurveyMsgs.Count = 0 Then MsgBox "There are no messages in the " & sSurveyAnswersFolder & " folder in the Inbox." End End If bGotQuestionText = False 'read each line in message into an array Set FSO = CreateObject("Scripting.FileSystemObject") For Each oMsg In oSurveyMsgs 'open temp file for writing, insert text from message, then close file Set oMsgTextFile = FSO.OpenTextFile(sTempMsgFilename, ForWriting, True) oMsgTextFile.Write (oMsg.Text) oMsgTextFile.Close 'open temp file for reading, read until last line of text in file to get count, then close file Set oMsgTextFile = FSO.OpenTextFile(sTempMsgFilename, ForReading) While Not oMsgTextFile.AtEndOfStream sDummy = oMsgTextFile.ReadLine Wend iTotalLines = oMsgTextFile.Line oMsgTextFile.Close 'open temp file for reading, read each line of text in file into array, then ' close file & delete it Set oMsgTextFile = FSO.OpenTextFile(sTempMsgFilename, ForReading) ReDim sMsgText(iTotalLines + 1) For iLineCtr = 1 To iTotalLines - 1 sMsgText(iLineCtr) = oMsgTextFile.ReadLine Next oMsgTextFile.Close FSO.DeleteFile (sTempMsgFilename) iLineCtr = 1 If Not bGotQuestionText Then 'each question is prefaced by "Q[number]:", and concludes when reach the corresponding ' answer line, prefaced by "A[number]:". 'find each "Q[number]:" line, find the line where "A[number]:" begins, and ' save the question text between. For iQCtr = 1 To iNumQuestions 'find beginning of next question While Left(sMsgText(iLineCtr), 3) <> "Q" & iQCtr & ":" iLineCtr = iLineCtr + 1 Wend 'find beginning of corresponding answer, and save question text lines While Left(sMsgText(iLineCtr), 3) <> "A" & iQCtr & ":" sQuestionText(iQCtr) = sQuestionText(iQCtr) & sMsgText(iLineCtr) iLineCtr = iLineCtr + 1 Wend 'remove the "Q1: Agree Scale: "-type language from the beginning of the question sQuestionText(iQCtr) = Right(sQuestionText(iQCtr), Len(sQuestionText(iQCtr)) - 4 - Len(sQDescr(iQCtr))) Next 'iQCtr bGotQuestionText = True End If 'find beginning of answer section While Left(sMsgText(iLineCtr), 22) <> "Pipe-delimited Format:" iLineCtr = iLineCtr + 1 Wend iLineCtr = iLineCtr + 1 'now at first line of answer section 'go through all the answer lines 'initialize arrays for this message For iQCtr = 1 To iNumQuestions sFullAnswer(iQCtr) = Null Next sAnswerPieces = Split("dummy dummy dummy") For iQCtr = 0 To UBound(sAnswerPieces) sAnswerPieces(iQCtr) = "" Next iOnCurrentAnswer = 1 While (iLineCtr <= iTotalLines) And (iLineCtr <= iTotalLines) sAnswerPieces = Split(sMsgText(iLineCtr), "\|") 'if an answer (would have to be Text) is continued from prior line(s), append CRLF & new string ' to same answer number, else increment the answer number For iACtr = 0 To UBound(sAnswerPieces) 'if no answer recorded for this question yet, then record it If (IsNull(sFullAnswer(iOnCurrentAnswer))) Or (Len(sFullAnswer(iOnCurrentAnswer)) = 0) Then sFullAnswer(iOnCurrentAnswer) = sAnswerPieces(iACtr) Else 'this question already has a part of the answer recorded, so append CRLF to end sFullAnswer(iOnCurrentAnswer) = sFullAnswer(iOnCurrentAnswer) & vbCrLf 'then append the new piece of the answer to the already-recorded answer sFullAnswer(iOnCurrentAnswer) = sFullAnswer(iOnCurrentAnswer) & sAnswerPieces(iACtr) End If 'if not at last (piece of) answer in this line, increment the Current Answer counter If iACtr < UBound(sAnswerPieces) Then If iOnCurrentAnswer < iNumQuestions Then iOnCurrentAnswer = iOnCurrentAnswer + 1 End If Next iLineCtr = iLineCtr + 1 Wend 'now that have all answers segregated in sFullAnswer variables, strip away the ' leading and trailing quote characters for each answer For iQCtr = 1 To iNumQuestions sFullAnswer(iQCtr) = Left(sFullAnswer(iQCtr), Len(sFullAnswer(iQCtr)) - 1) sFullAnswer(iQCtr) = Right(sFullAnswer(iQCtr), Len(sFullAnswer(iQCtr)) - 1) Next '**************************** 'ACCUMULATE ANSWERS FOR REPORTING '**************************** 'for each question, find question type. ' if Text, then append answer to end of existing accumulated text answers for that question ' if any other, let (x) the number of times that answer's been given = x + 1 For iACtr = 1 To iNumQuestions Select Case sQType(iACtr) Case "A" 'Agree Scale Select Case sFullAnswer(iACtr) Case "Strongly Disagree" iStrDisagree(iACtr) = iStrDisagree(iACtr) + 1 Case "Disagree" iDisagree(iACtr) = iDisagree(iACtr) + 1 Case "Neutral" iNeutral(iACtr) = iNeutral(iACtr) + 1 Case "Agree" iAgree(iACtr) = iAgree(iACtr) + 1 Case "Strongly Agree" iStrAgree(iACtr) = iStrAgree(iACtr) + 1 Case Else iNotAnswered(iACtr) = iNotAnswered(iACtr) + 1 End Select Case "T" 'Text Select Case sFullAnswer(iACtr) Case Null, "" iNotAnswered(iACtr) = iNotAnswered(iACtr) + 1 Case Else sText(iACtr) = sText(iACtr) & sFullAnswer(iACtr) 'create visual separator sText(iACtr) = sText(iACtr) & vbCrLf & " ******" & vbCrLf End Select Case "Y" 'Yes/No/NA Select Case sFullAnswer(iACtr) Case "Yes" iYes(iACtr) = iYes(iACtr) + 1 Case "No" iNo(iACtr) = iNo(iACtr) + 1 Case "NA" iNA(iACtr) = iNA(iACtr) + 1 Case Else iNotAnswered(iACtr) = iNotAnswered(iACtr) + 1 End Select Case "R" 'Rating of 1 - 10 Select Case sFullAnswer(iACtr) Case "1" i1(iACtr) = i1(iACtr) + 1 Case "2" i2(iACtr) = i2(iACtr) + 1 Case "3" i3(iACtr) = i3(iACtr) + 1 Case "4" i4(iACtr) = i4(iACtr) + 1 Case "5" i5(iACtr) = i5(iACtr) + 1 Case "6" i6(iACtr) = i6(iACtr) + 1 Case "7" i7(iACtr) = i7(iACtr) + 1 Case "8" i8(iACtr) = i8(iACtr) + 1 Case "9" i9(iACtr) = i9(iACtr) + 1 Case "10" i10(iACtr) = i10(iACtr) + 1 Case Else iNotAnswered(iACtr) = iNotAnswered(iACtr) + 1 End Select Case "C" 'Configured options Select Case sFullAnswer(iACtr) Case sChoice1 iChoice1(iACtr) = iChoice1(iACtr) + 1 Case sChoice2 iChoice2(iACtr) = iChoice2(iACtr) + 1 Case sChoice3 iChoice3(iACtr) = iChoice3(iACtr) + 1 Case sChoice4 iChoice4(iACtr) = iChoice4(iACtr) + 1 Case sChoice5 iChoice5(iACtr) = iChoice5(iACtr) + 1 Case sChoice11 iChoice11(iACtr) = iChoice11(iACtr) + 1 Case sChoice12 iChoice12(iACtr) = iChoice12(iACtr) + 1 Case sChoice13 iChoice13(iACtr) = iChoice13(iACtr) + 1 Case sChoice14 iChoice14(iACtr) = iChoice14(iACtr) + 1 End Select End Select Next 'iACtr Next 'oMsg in oSurveyMsgs '*************************** 'GENERATE REPORT FILE OF RESULTS '*************************** 'user gives [path &] filename for the text file to create/overwrite, and all questions and answer accumulations are written to that file. Do bGotGoodFilenameAndPath = True sFnAndPath = InputBox("Please enter the path and filename for the results text file:") ' if user doesn't enter a full path, then append C:\ to the front of it If Not InStr(sFnAndPath, ":") Then sFnAndPath = "C:\" & sFnAndPath End If 'test to see if such a path & filename is valid On Error Resume Next Set oResultsTextFile = FSO.OpenTextFile(sFnAndPath, ForWriting, True) If Not FSO.FileExists(sFnAndPath) Then bGotGoodFilenameAndPath = False MsgBox "'" & sFnAndPath & "' is not a valid path and filename -- please try again." End If Loop Until bGotGoodFilenameAndPath sReportTitle = InputBox("What title do you want to give this report?") oResultsTextFile.writeline sReportTitle oResultsTextFile.writeblanklines (2) For iQCtr = 1 To iNumQuestions oResultsTextFile.writeline "Question " & iQCtr & ":" oResultsTextFile.writeline sQuestionText(iQCtr) oResultsTextFile.writeblanklines (1) Select Case sQType(iQCtr) Case "A" 'Agree Scale oResultsTextFile.writeline vbTab & iStrDisagree(iQCtr) & vbTab & "Strongly Disagree" oResultsTextFile.writeline vbTab & iDisagree(iQCtr) & vbTab & "Disagree" oResultsTextFile.writeline vbTab & iNeutral(iQCtr) & vbTab & "Neutral" oResultsTextFile.writeline vbTab & iAgree(iQCtr) & vbTab & "Agree" oResultsTextFile.writeline vbTab & iStrAgree(iQCtr) & vbTab & "Strongly Agree" oResultsTextFile.writeline vbTab & iNotAnswered(iQCtr) & vbTab & "Not Answered" Case "T" 'Text If iNotAnswered(iQCtr) = 1 Then sWord = " person " Else sWord = " people " End If oResultsTextFile.writeline vbTab & "(" & iNotAnswered(iQCtr) & sWord & "did not answer this question.)" oResultsTextFile.writeline " *******" oResultsTextFile.writeline sText(iQCtr) Case "Y" 'Yes/No/NA oResultsTextFile.writeline vbTab & iYes(iQCtr) & vbTab & "Yes" oResultsTextFile.writeline vbTab & iNo(iQCtr) & vbTab & "No" oResultsTextFile.writeline vbTab & iNA(iQCtr) & vbTab & "Not Applicable" oResultsTextFile.writeline vbTab & iNotAnswered(iQCtr) & vbTab & "Not Answered" Case "R" 'Rating of 1 - 10 oResultsTextFile.writeline vbTab & i1(iQCtr) & vbTab & "'1' Rating" oResultsTextFile.writeline vbTab & i2(iQCtr) & vbTab & "'2' Rating" oResultsTextFile.writeline vbTab & i3(iQCtr) & vbTab & "'3' Rating" oResultsTextFile.writeline vbTab & i4(iQCtr) & vbTab & "'4' Rating" oResultsTextFile.writeline vbTab & i5(iQCtr) & vbTab & "'5' Rating" oResultsTextFile.writeline vbTab & i6(iQCtr) & vbTab & "'6' Rating" oResultsTextFile.writeline vbTab & i7(iQCtr) & vbTab & "'7' Rating" oResultsTextFile.writeline vbTab & i8(iQCtr) & vbTab & "'8' Rating" oResultsTextFile.writeline vbTab & i9(iQCtr) & vbTab & "'9' Rating" oResultsTextFile.writeline vbTab & i10(iQCtr) & vbTab & "'10' Rating" oResultsTextFile.writeline vbTab & iNotAnswered(iQCtr) & vbTab & "Not Answered" Case "C" 'Configured options 'not figured out the logic on reporting by question* when there are more than one Choice-type questions, ' so totals for ALL Choice-type answers will print for each question, and the irrelevant ones ' should be deleted manually for each question from the resulting text file. ' Still easier than accumulating all answers manually.... oResultsTextFile.writeline vbTab & iChoice1(iQCtr) & vbTab & sChoice1 oResultsTextFile.writeline vbTab & iChoice2(iQCtr) & vbTab & sChoice2 oResultsTextFile.writeline vbTab & iChoice3(iQCtr) & vbTab & sChoice3 oResultsTextFile.writeline vbTab & iChoice4(iQCtr) & vbTab & sChoice4 oResultsTextFile.writeline vbTab & iChoice5(iQCtr) & vbTab & sChoice5 oResultsTextFile.writeline vbTab & iChoice11(iQCtr) & vbTab & sChoice11 oResultsTextFile.writeline vbTab & iChoice12(iQCtr) & vbTab & sChoice12 oResultsTextFile.writeline vbTab & iChoice13(iQCtr) & vbTab & sChoice13 oResultsTextFile.writeline vbTab & iChoice14(iQCtr) & vbTab & sChoice14 End Select oResultsTextFile.writeline vbCrLf & vbCrLf Next 'iQCtr oResultsTextFile.Close MsgBox "Results have been saved in the file '" & sFnAndPath & "'" End Sub
All 25comments

	Page [ 1 2 3 Next >> ]
	Robert E. Williams 29-Jun-2004 18:13 Has anyone been able to run this including reporting? Is there a way to bypass security? Anyone with an interest to help a newbie take baby steps?
	Sue Mosher 30-Jun-2004 09:29 To bypass security prompts, you'd need to upgrade to Outlook 2003 or recode the form using Redemption (http://www.dimastr.com/redemption )
	Matthew Bell 15-Jul-2004 14:34 Just found that there's another prerequisite (that I already had enabled, but didn't realize it was required): To run this code, you must go to Tools, References in the VBA Editor and select the "Microsoft CDO 1.21 Library".
	Sue Mosher 20-Jul-2004 10:31 You're using CDO 1.21 only for better performance and memory, right?
	Matthew Bell 20-Jul-2004 12:56 Nope -- when I tried to run this code on my boss' machine, it gave an error saying it couldn't recognize a certain "user-defined" variable. I was already using the CDO 1.21 Library on my own machine for a different set of code (re: getting senders' SMTP addresses), so I thought maybe I'd copied code into this script that required CDO 1.21. After I selected the CDO 1.21 Library on my boss' machine, the code then worked. So I dunno -- I'm still a newbie when it comes to the CDO side of things.
	Anonymous 20-Sep-2004 11:56 I have installed the form and have begun creating Surveys. I have made the changes to the two lines of code as instructed. I now get a "Unterminated String constant at line 373 error" I click Ok and the Form opens. How do I fix this error and what steps are there to running the compilation code after you receive your survey replys?
	Dominic Fino 27-Sep-2004 12:37 I too received the error on line 373. I corrected it (maybe wrongly) by adding a closing double quote. .....Chr(34) & "!" Now I receive an error on line 444 - expecting end of statement. Not sure how to fix this one. Anyone have an idea? Dom Fino
	Sue Mosher 28-Sep-2004 07:38 Dom, it might help if you showed the code for statement 444 and maybe a little of the code near it.
	Matthew Bell 28-Sep-2004 09:17 You're right, I missed a closing quote in my instructions above for the two changes to be made -- sorry. The second "from... to..." should read as follows (now includes the closing quote at the very end): 'and from ' strcsvanswers = strcsvanswers & Chr(34) & aryAnswers(I) & Chr(34) & "," 'to ' strcsvanswers = strcsvanswers & Chr(34) & aryAnswers(I) & Chr(34) & "\|"
	Matt Franz 02-Nov-2004 15:09 Where does one include this vbs script? (I guess installation instructions are what I am looking for) Thanks!!
	Page [ 1 2 3 Next >> ]

name email