i trying set automated process company work for. have set our hr system send out rich text table (only format) of employees taking time off in near future.
the hr system capable of storing time vacation, pto, & sick time every month. wrote code in sql have system send out monthly table of employees have time off in next month listed.
i attempting take information , have populate our outlook calendars. currently, have set excel sheet populate persons calendar list after information has been copied , pasted sheet.
ideally have information automatically copy excel sheet or set system creates appointments within outlook. i'm bit stumped @ moment.
all of previous attempts accomplish either goal have failed. i'm noob when comes vba, can appreciated. thank you.
the email looks lot of control (the blue row header , information in placed in rows underneath it):
edit: added improvements suggested @patrickk , added image of spreadsheet.
i figured out. looking @ issue wrong, didn't realize copy entire body of email clipboard , paste in excel spreadsheet without formatting getting wonky. came with, appears work well:
'____________________________________________________________ ' ' author: joshua bryant ' ' version 1.1 ' ' date: 8/16/2016 ' ' routine search system notifier email ' holds leave data. once found, call ' copy_paste_data sub routine take data ' selected email , copy clipboard. once ' copied subroutine paste excel ' leave notifier table workbook. calls add_time ' subroutine adjust start , end time columns of ' worksheet allow more readable calendar. ' routine temporarily disables excel notifications ' public, passes olitem copy_paste_data, returns nothing. ' ' version 1.1: added exit loop if statement, exit ' loop once email has been found (if found exit for). ' __________________________________________________________ ' public sub get_data() ' declare variables dim myolapp new outlook.application dim mynamespace outlook.namespace dim myinbox outlook.mapifolder dim myitems outlook.items dim myitem object dim found boolean dim olitem mailitem dim objinsp outlook.inspector dim mydate variant dim datestr string dim ooutlook object ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' un-comment following section have program check , ' make sure outlook open before proceeding. not ' necessary program operate effectively: ' ' on error resume next ' set ooutlook = getobject(, "outlook.application") ' on error goto 0 ' ' if ooutlook nothing ' msgbox "outlook mail not open. please open outlook mail , try again." ' exit sub ' end if ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' on error (wrong data type found) skip item , ' continue email. on error resume next ' initialize objinsp variable inspector item can ' used search for, , point, items in outlook folder set objinsp = outlook.application.activeinspector ' create string item holds todays date in formatted manner. datestr = cstr(datepart("m", date)) & "/" & cstr(datepart("d", date)) & "/" & cstr(datepart("yyyy", date)) ' initialize variables , select default message folder search. set mynamespace = myolapp.getnamespace("mapi") set myinbox = mynamespace.getdefaultfolder(olfolderinbox) set myitems = myinbox.items ' set intitial state of found variable false found = false ' loop search through items in selected mail folder. each myitem in myitems ' if item belongs outlook mail class continue. ' else continue looking until no items present. if myitem.class = olmail ' once mail item found compare it's subject string. ' if sting matchs hold selected item , set found variable true. ' else continue looking until no items present. if instr(1, myitem.subject, datestr & " upcoming leave notifier") > 0 ' set held item equal mailitem type variable hold later use. ' takes object being pointed , saves later use. set olitem = myitem ' set true "flag" (make found variable true) found = true if found exit end if end if next myitem ' once items have been searched check if found "flag" true ' if true notify end user , procede copying , pasting data worksheept. ' if false go else. if found = true msgbox "data found." ' if found pass item copy_paste_data , call sub rountine. copy_paste_data olitem ' else query end user date when email recieved. else: ' set point return if item still not found @ user provided date. not_found: ' prompt user date when email recieved system. mydate = inputbox("email todays date not found." & chr(13) & chr(13) & "please enter date email recieved in field below. date should written in mm/dd/yyyy format." & chr(13) & chr(13) & "note: not include leading zeros. ex. 01/02/2015 should 1/2/2015" & chr(13)) ' if user not enter value or presses cancle exit routine. if mydate = "" exit sub ' repeat search email new date value. each myitem in myitems if myitem.class = olmail if instr(1, myitem.subject, mydate & " upcoming leave notifier") > 0 set olitem = myitem found = true if found exit end if end if next myitem ' query again see if email found if found = true ' if found pass item copy_paste_data , call sub rountine. copy_paste_data olitem ' else, repeat prompt end user. else: goto not_found end if end if ' once information has been added run add time index results start , end times. call add_time end sub '____________________________________________________________ ' ' author: joshua bryant ' ' version 1.0 ' ' date: 8/15/2016 ' ' subroutine takes object passed get_data , ' copies data body of email. pastes ' data active excel sheet. ' subroutine temporarily disables excel display alerts ' private, returns nothing. '____________________________________________________________ ' private sub copy_paste_data(olitem) ' delcare / initialize variable dim dataobj msforms.dataobject set dataobj = new msforms.dataobject ' copy html body of email data object dataobj.settext olitem.htmlbody ' copy data object clipboard dataobj.putinclipboard ' disable display alerts (e.g. size doesn't match warning) application.displayalerts = false ' paste contents of clipboard worksheet (dimensions dont have match exactly) activesheet.paste destination:=worksheets("leave table").range("a3:g300") ' notify end user data transfer successful. msgbox "your data has been transfered successfully." ' re-enable excel alerts application.displayalerts = true end sub '____________________________________________________________ ' ' author: joshua bryant ' ' version 1.0 ' ' date: 8/15/2016 ' ' subroutine examines items in table , looks ' days multiple employees have requested time off ' on days increment each employees scheduled ' start , end time 30 minutes provide cleaner ' appointment view on calendar. allows names ' appear though listed on days of week ' added to. each new date, routine ' begin appointment start times @ 8:00 , add 30 ' minuted every subsequent employee. ' private, returns nothing. '____________________________________________________________ ' private sub add_time() ' initialize variables dim time date dim holddate date dim prevrowdate date dim lastdate date dim lastname string dim nextrowdate date ' set work sheet edited dim wssrc worksheet set wssrc = activeworkbook.sheets("leave table") ' set initial values holddate = datevalue(wssrc.cells(4, 3)) prevrowdate = datevalue(wssrc.cells(4, 3)) time = timevalue("08:00:00") ' set values first row (after header) of table (row 3) wssrc.cells(4, 8).value = timevalue("08:00:00") wssrc.cells(4, 9).value = timevalue("08:30:00") r = 4 ' loop find end of list until trim(wssrc.cells(r, 1).value) = "" r = r + 1 loop ' set second last item ending point. ' not want use last row because throw data type error when end reached. r = r - 1 lastname = wssrc.cells(r, 1).value lastdate = datevalue(wssrc.cells(r, 3)) ' begin @ row 4 (rows 1 & 2 headers. beginning @ row 3 include invalid data type row 2) r = 5 ' repeat loop until second last row reached. until wssrc.cells(r, 1).value = wssrc.cells(r, 1).value , datevalue(wssrc.cells(r, 3)) = lastdate ' hold date in current row holddate = datevalue(wssrc.cells(r, 3)) ' set next date equal date being held. ' allows next loops conditions met entry do/while loop. nextrowdate = datevalue(wssrc.cells(r, 3)) ' date previous row , hold comparison held date. ' done endure add time loop not entered prematurely. r = r - 1 prevrowdate = datevalue(wssrc.cells(r, 3)) r = r + 1 ' add time loop increment time in calendar 30 minutes ' while holddate not equal prevrowdate or nextrowdate. ' note: previous row date holds same value recieved outside of loop. ' thus, condition relies entirely on nextrowdate. until holddate <> prevrowdate or holddate <> nextrowdate ' date of next row. r = r + 1 nextrowdate = datevalue(wssrc.cells(r, 3)) r = r - 1 ' plase current time value + 30 min start time column of row wssrc.cells(r, 8).value = cdate(time) + 1 / 48 ' add 30 min time value time = cdate(time) + 1 / 48 ' plase current time value + 30 min end time column of row wssrc.cells(r, 9).value = cdate(time) + 1 / 48 ' increment row r = r + 1 loop ' reset time 8:00 time = timevalue("08:00:00") ' place 8:00 in start time column of row wssrc.cells(r, 8).value = cdate(time) ' place 8:30 in end time column of row wssrc.cells(r, 9).value = cdate(time) + 1 / 48 ' increment row r = r + 1 loop ' add time values last date in table. ' begin @ 7:30 simplicity time = timevalue("07:30:00") ' repeat loop add start , end times each person on last day of ' table, adding 30 minutes each time. until trim(wssrc.cells(r, 1).value) = "" wssrc.cells(r, 8).value = cdate(time) + 1 / 48 time = cdate(time) + 1 / 48 wssrc.cells(r, 9).value = cdate(time) + 1 / 48 r = r + 1 loop end sub the spreadsheet goes out , finds notification email today's date , copies , pastes spreadsheet can edited , later uploaded directly global calendar using following program:
'____________________________________________________________ ' ' author: joshua bryant ' ' version 1.0 ' ' date: 8/16/2016 ' ' main program call other subs. ' create_outlook sub calls clean_leave_calendar sub ' delete emails leave calendar before attempting ' add new items calendar. once calendar has ' been cleaned , times have been added, program ' creates new appointments items in predetermined outlook ' folder "ofolder". once appointment items have been ' created program notifies end user process ' ran , runs close_workbook subroutine ' close workbook without saving. '____________________________________________________________ ' public sub populate_calendar() ' initialize variables dim oapp object dim onamespace namespace dim ofolder object dim wssrc worksheet set wssrc = sheets("leave table") ' call subroutines call clean_leave_calendar ' start looping @ row 3 (first 2 rows readability) r = 4 ' do/while set condition until trim(wssrc.cells(r, 1).value) = "" ' create outlook session set oapp = new outlook.application ' set namespace set onamespace = oapp.getnamespace("mapi") ' set folder appointment created in. set ofolder = onamespace.getfolderfromid("000000007cf129e6c6baa74f9b2ab399fabb280e01006ec36ffc70429b4eae1875321a4609670078c4fa00320000").items.add(olappointmentitem) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' use following code in outlook find folder id #: ' note: calendar want create appointments in ' selected, press f11 bring outlook macros , run ' code under "thisoutlooksession" ' ' private sub getoutlookfolderid() ' 'determines folder id of folder ' dim olfolder outlook.mapifolder ' dim olapp outlook.application ' set olapp = createobject("outlook.application") ' set olfolder = olapp.getnamespace("mapi").pickfolder ' olfolder.display ' msgbox (olfolder.entryid) ' set olfolder = nothing ' set olapp = nothing ' end sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' set block appointment configuration loop ofolder ' set subject line of event .subject = wssrc.cells(r, 1).value & " " & wssrc.cells(r, 2).value ' set start time .start = datevalue(wssrc.cells(r, 3)) + wssrc.cells(r, 8).value ' set end time .end = datevalue(wssrc.cells(r, 3)) + wssrc.cells(r, 9).value ' turn reminders off .reminderset = false ' set busy status free .busystatus = 0 ' have body of event read decription leave form in viewpoint .body = wssrc.cells(r, 4).value ' save event in owners calendar .save ' end block end ' move next row r = r + 1 ' repeat do/while loop until condition no longer valid loop ' clean house set oapp = nothing set onamespace = nothing set ofolder = nothing set wssrc = nothing msgbox "data added outlook leave calendar." & chr(13) & chr(13) & "excel workbook close." call closeworkbook end sub '____________________________________________________________ ' ' author: joshua bryant ' ' version 1.0 ' ' date: 8/15/2016 ' ' sub close current workbook without saving. ' before closing check make sure there no ' other workbooks open , if there none, ' close excel application well. sub ' temporarily disable displayed "would save ' workbook" notification. ' private, returns nothing. '____________________________________________________________ ' private sub closeworkbook() application.displayalerts = false if workbooks.count < 2 application.quit else thisworkbook.close end if end sub '____________________________________________________________ ' ' author: joshua bryant ' ' version 1.0 ' ' date: 8/15/2016 ' ' sub call clean_leave_calendar subroutine ' 5 times. clean_leave_calendar subroutine ' appointment items in predefined outlook folder. once ' appointment item identified program ' perminately delete item avoid scheduling conflicts ' new items added. deletion loop runs 10 ' times ensure items removed. ' public, returns nothing '____________________________________________________________ ' public sub power_wash() dim integer = 0 until = 5 call clean_leave_calendar = + 1 loop end sub '____________________________________________________________ ' ' author: joshua bryant ' ' version 1.0 ' ' date: 8/15/2016 ' ' sub appointment items in predefined ' outlook folder. once appointment item identified ' program perminately delete item avoid schedule ' conflicts new items added. deletion loop ' runs 10 times ensure items removed ' private, returns nothing '____________________________________________________________ ' private sub clean_leave_calendar() ' initialize variables dim oapp outlook.application dim onamespace outlook.namespace dim oapptitem outlook.appointmentitem dim ofolder outlook.mapifolder dim omeetingoapptitem outlook.meetingitem dim oobject object dim integer ' set error states on error resume next ' check if outlook running set oapp = getobject("outlook.application") if err <> 0 'if outlook not running, start it. set oapp = createobject("outlook.application") end if ' set folder appointments can found in. see main function "create outlook" more details. set oapp = new outlook.application set onamespace = oapp.getnamespace("mapi") set ofolder = onamespace.getfolderfromid("000000007cf129e6c6baa74f9b2ab399fabb280e01006ec36ffc70429b4eae1875321a4609670078c4fa00320000") ' set initial value of 0 = 0 ' repeat deleting function 10 times make sure apointments have been cleared folder. until = 10 checkappointment = false ' each of "objects" appointments , other in folder specified above repeat loop. ' beacause not of objects appointments ends early, ' why runs 10 times. (easier coding more stringent code, , not ' resource demanding). each oobject in ofolder.items ' compare each object appoint class , delete objects match found. if oobject.class = olappointment set oapptitem = oobject oapptitem.delete end if ' repeat each object / item. next oobject ' rinse , repeat. = + 1 loop ' clear variables set oapp = nothing set onamespace = nothing set oapptitem = nothing set ofolder = nothing set oobject = nothing end sub a subroutine clears shared calendar. main routine uploads new dates. lastly, subroutine closes workbook.
if has suggestions cleaning up, please let me know.
thanks!
also, here image of excel sheet using.
Comments
Post a Comment