EDIT: Hinzugefügt Verbesserungen von @PatrickK vorgeschlagen und hinzugefügt Bild der Tabelle.
Ich fand es schließlich heraus. Ich habe mir das Problem komplett falsch angeguckt, mir war nicht klar, dass ich den gesamten Text der E-Mail in die Zwischenablage kopieren und dann in die Excel-Tabelle einfügen konnte, ohne dass die Formatierung komplett verworren wurde. Das ist, was ich kam mit, das gut zu funktionieren scheint:
'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.1
'
' Date: 8/16/2016
'
' This routine will search for the system notifier email
' which holds the leave data. Once found, it will call the
' Copy_Paste_Data sub routine which will take the data from
' the selected email and copy it to the clipboard. Once
' copied the subroutine will then paste it into the Excel
' Leave Notifier Table Workbook. It then calls the Add_Time
' subroutine to adjust the start and end time columns of the
' worksheet to allow for a more readable calendar.
' This routine temporarily disables Excel notifications
' Public, passes olItem to Copy_Paste_Data, returns nothing.
'
' Version 1.1: Added exit for loop if statement, to exit
' loop once email has been found (If Found Then Exit For).
' __________________________________________________________
'
Public Sub Get_Data()
' Declare Variables
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Dim olItem As MailItem
Dim objInsp As Outlook.Inspector
Dim myDate As Variant
Dim DateStr As String
Dim oOutlook As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Un-comment the following section to have program check and
' make sure Outlook is open before proceeding. This is not
' necessary for this program to operate effectively:
'
' On Error Resume Next
' Set oOutlook = GetObject(, "Outlook.Application")
' On Error GoTo 0
'
' If oOutlook Is Nothing Then
' MsgBox "Outlook Mail is not open. Please open Outlook Mail and try again."
' Exit Sub
' End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' On error (wrong data type found) it will skip the item and
' continue to look for the email.
On Error Resume Next
' Initialize objInsp variable as an inspector item which can be
' used to search for, and point, to items in the outlook folder
Set objInsp = Outlook.Application.ActiveInspector
' Create a string item which holds todays date in a specifically formatted manner.
DateStr = CStr(DatePart("m", Date)) & "/" & CStr(DatePart("d", Date)) & "/" & CStr(DatePart("yyyy", Date))
' Initialize variables and select default message folder for search.
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
' Set intitial state of Found variable to False
Found = False
' For loop to search through all items in the selected mail folder.
For Each myitem In myitems
' If the item belongs to outlook mail class continue.
' Else continue looking until no items are present.
If myitem.Class = olMail Then
' Once mail item is found compare it's subject to this string.
' If sting matchs hold selected item and set Found variable to true.
' Else continue looking until no items are present.
If InStr(1, myitem.Subject, DateStr & " Upcoming Leave Notifier") > 0 Then
' Set the held item equal to MailItem type variable to hold it for later use.
' Takes object being pointed to and saves it for later use.
Set olItem = myitem
' Set true "flag" (make Found variable True)
Found = True
If Found Then Exit For
End If
End If
Next myitem
' Once all items have been searched check if Found "flag" is true
' If true notify end user and procede to copying and pasting data into worksheept.
' If False go to Else.
If Found = True Then
MsgBox "Data Found."
' If found pass item to Copy_Paste_Data and call sub rountine.
Copy_Paste_Data olItem
' Else query end user for date when email was recieved.
Else:
' Set point to return to if item was still not found at user provided date.
Not_Found:
' Prompt user for date when email was recieved from the system.
myDate = InputBox("Email with todays date not found." & Chr(13) & Chr(13) & "Please enter the date that the email was recieved in the field below. The date should be written in the mm/dd/yyyy format." & Chr(13) & Chr(13) & "Note: Do not include leading zeros. Ex. 01/02/2015 should be 1/2/2015" & Chr(13))
' If the user does not enter a value or presses Cancle then exit routine.
If myDate = "" Then Exit Sub
' Repeat search for email with new date value.
For Each myitem In myitems
If myitem.Class = olMail Then
If InStr(1, myitem.Subject, myDate & " Upcoming Leave Notifier") > 0 Then
Set olItem = myitem
Found = True
If Found Then Exit For
End If
End If
Next myitem
' Query again to see if email was found
If Found = True Then
' If found pass item to Copy_Paste_Data and call sub rountine.
Copy_Paste_Data olItem
' Else, repeat prompt to end user.
Else:
GoTo Not_Found
End If
End If
' Once information has been added run add time to index results with start and end times.
Call Add_Time
End Sub
'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/15/2016
'
' This subroutine takes object passed from Get_Data and
' copies the data from the body of the email. It then pastes
' that data into the active Excel sheet.
' This subroutine temporarily disables Excel Display Alerts
' Private, returns nothing.
'____________________________________________________________
'
Private Sub Copy_Paste_Data(olItem)
' Delcare/Initialize variable
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
' Copy HTML body of email to data object
DataObj.SetText olItem.HTMLBody
' Copy data object to clipboard
DataObj.PutInClipboard
' Disable display alerts (e.g. size doesn't match warning)
Application.DisplayAlerts = False
' Paste the contents of the clipboard to the worksheet (dimensions dont have to match exactly)
ActiveSheet.Paste Destination:=Worksheets("Leave Table").Range("A3:G300")
' Notify end user that data transfer was 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
'
' This subroutine examines the items in the table and looks
' for days where multiple employees have requested time off
' On those days it will increment each employees scheduled
' start and end time by 30 minutes to provide a cleaner
' appointment view on the calendar. This allows the names to
' appear as though they are listed on the days of the week
' they are added to. For each new date, the routine will
' begin the appointment start times at 8:00 AM and add 30
' minuted for every subsequent employee.
' Private, returns nothing.
'____________________________________________________________
'
Private Sub Add_Time()
' Initialize variables
Dim time As Date
Dim HoldDate As Date
Dim PrevRowDate As Date
Dim LastDate As Date
Dim LastName As String
Dim NextRowDate As Date
' Set Work sheet to be edited
Dim wsSrc As 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 for first row (after header) of the table (row 3)
wsSrc.Cells(4, 8).Value = TimeValue("08:00:00")
wsSrc.Cells(4, 9).Value = TimeValue("08:30:00")
r = 4
' Loop to find the end of the list
Do Until Trim(wsSrc.Cells(r, 1).Value) = ""
r = r + 1
Loop
' Set the second to last item as the ending point.
' We do not want to use the last row because it would throw a data type error when the end is reached.
r = r - 1
LastName = wsSrc.Cells(r, 1).Value
LastDate = DateValue(wsSrc.Cells(r, 3))
' Begin at row 4 (Rows 1 & 2 are headers. Beginning at row 3 would include invalid data type from row 2)
r = 5
' Repeat this loop until the second to last row is reached.
Do Until wsSrc.Cells(r, 1).Value = wsSrc.Cells(r, 1).Value And DateValue(wsSrc.Cells(r, 3)) = LastDate
' Hold the date in the current row
HoldDate = DateValue(wsSrc.Cells(r, 3))
' Set the next date equal to the date being held.
' This allows for the next loops conditions to be met for entry into the do/while loop.
NextRowDate = DateValue(wsSrc.Cells(r, 3))
' Get the date from the previous row and hold it for comparison to the held date.
' This is done to endure the add time loop is not entered prematurely.
r = r - 1
PrevRowDate = DateValue(wsSrc.Cells(r, 3))
r = r + 1
' Add time loop to increment time in calendar by 30 minutes
' while HoldDate does not equal PrevRowDate or NextRowDate.
' Note: Previous row date holds the same value it recieved from outside of the loop.
' Thus, the condition relies entirely on the NextRowDate.
Do Until HoldDate <> PrevRowDate Or HoldDate <> NextRowDate
' Get the date of the next row.
r = r + 1
NextRowDate = DateValue(wsSrc.Cells(r, 3))
r = r - 1
' Plase the current time value + 30 min into the Start time column of this row
wsSrc.Cells(r, 8).Value = CDate(time) + 1/48
' Add 30 min to the time value
time = CDate(time) + 1/48
' Plase the current time value + 30 min into the End time column of this row
wsSrc.Cells(r, 9).Value = CDate(time) + 1/48
' Increment row
r = r + 1
Loop
' Reset time to 8:00 AM
time = TimeValue("08:00:00")
' Place 8:00 Am in the Start time column of this row
wsSrc.Cells(r, 8).Value = CDate(time)
' Place 8:30 Am in the End time column of this row
wsSrc.Cells(r, 9).Value = CDate(time) + 1/48
' Increment row
r = r + 1
Loop
' Add time values for the last date in the table.
' Begin at 7:30 AM for simplicity
time = TimeValue("07:30:00")
' Repeat loop to add start and end times for each person on the last day of the
' table, adding 30 minutes each time.
Do 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
Die Tabelle geht und findet die Benachrichtigung E-Mail mit dem heutigen Datum und dann kopiert und fügt sie in die Tabelle, wo sie bearbeitet werden kann und später hochgeladen Mit dem folgenden Programm wird direkt in den globalen Kalender geschrieben:
'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/16/2016
'
' This is the main program which will call the other subs.
' The Create_Outlook sub calls Clean_Leave_Calendar sub to
' delete all emails from the leave calendar before attempting
' to add new items to the calendar. Once the calendar has
' been cleaned and the times have been added, the program
' creates new appointments items in the predetermined outlook
' folder "oFolder". Once the appointment items have been
' created the program notifies the end user that the process
' ran successfully and runs Close_Workbook subroutine to
' close workbook without saving.
'____________________________________________________________
'
Public Sub Populate_Calendar()
' Initialize variables
Dim oApp As Object
Dim oNameSpace As Namespace
Dim oFolder As Object
Dim wsSrc As Worksheet
Set wsSrc = Sheets("Leave Table")
' Call subroutines
Call Clean_Leave_Calendar
' Start looping at row 3 (first two rows are for readability)
r = 4
' Do/while set condition
Do Until Trim(wsSrc.Cells(r, 1).Value) = ""
' Create the Outlook session
Set oApp = New Outlook.Application
' Set the namespace
Set oNameSpace = oApp.GetNamespace("MAPI")
' Set the folder the appointment will be created in.
Set oFolder = oNameSpace.GetFolderFromID("000000007CF129E6C6BAA74F9B2AB399FABB280E01006EC36FFC70429B4EAE1875321A4609670078C4FA00320000").Items.Add(olAppointmentItem)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Use the following code in Outlook to find the Folder ID #:
' Note: WITH THE CALENDAR YOU WANT TO CREATE APPOINTMENTS IN
' SELECTED, press F11 to bring up Outlook macros and run the
' code under "ThisOutlookSession"
'
' Private Sub GetOutlookFolderID()
' 'Determines the Folder ID of Folder
' Dim olfolder As Outlook.MAPIFolder
' Dim olapp As 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 with block for the appointment configuration loop
With 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 to free
.BusyStatus = 0
' Have the body of the event read as the decription from the leave form in Viewpoint
.Body = wsSrc.Cells(r, 4).Value
' Save event in owners calendar
.Save
' End with block
End With
' Move to next row
r = r + 1
' Repeat do/while loop until condition is no longer valid
Loop
' Clean house
Set oApp = Nothing
Set oNameSpace = Nothing
Set oFolder = Nothing
Set wsSrc = Nothing
MsgBox "Data was successfully added to the Outlook Leave Calendar." & Chr(13) & Chr(13) & "Excel workbook will now close."
Call CloseWorkbook
End Sub
'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/15/2016
'
' This sub will close the current workbook without saving.
' Before closing it will check to make sure there are no
' other workbooks are open and if there are none, it will
' close the Excel application as well. This sub will also
' temporarily disable displayed "Would you like to save your
' workbook" notification.
' Private, returns nothing.
'____________________________________________________________
'
Private Sub CloseWorkbook()
Application.DisplayAlerts = False
If Workbooks.Count < 2 Then
Application.Quit
Else
ThisWorkbook.Close
End If
End Sub
'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/15/2016
'
' This sub will call the Clean_Leave_Calendar subroutine
' 5 times. The Clean_Leave_Calendar subroutine will look for
' appointment items in the predefined outlook folder. Once
' an appointment item is identified the program will
' perminately delete the item to avoid scheduling conflicts
' with new items to be added. The deletion loop runs 10
' times to ensure all items are successfully removed.
' Public, returns nothing
'____________________________________________________________
'
Public Sub Power_Wash()
Dim i As Integer
i = 0
Do Until i = 5
Call Clean_Leave_Calendar
i = i + 1
Loop
End Sub
'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/15/2016
'
' This sub will look for appointment items in the predefined
' outlook folder. Once an appointment item is identified the
' program will perminately delete the item to avoid schedule
' conflicts with new items to be added. The deletion loop
' runs 10 times to ensure all items are successfully removed
' Private, returns nothing
'____________________________________________________________
'
Private Sub Clean_Leave_Calendar()
' Initialize variables
Dim oApp As Outlook.Application
Dim oNameSpace As Outlook.Namespace
Dim oApptItem As Outlook.AppointmentItem
Dim oFolder As Outlook.MAPIFolder
Dim oMeetingoApptItem As Outlook.MeetingItem
Dim oObject As Object
Dim i As Integer
' Set error states
On Error Resume Next
' Check if Outlook is running
Set oApp = GetObject("Outlook.Application")
If Err <> 0 Then
'If Outlook is not running, start it.
Set oApp = CreateObject("Outlook.Application")
End If
' Set the folder the appointments can be found in. See main function "Create Outlook" for more details.
Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("000000007CF129E6C6BAA74F9B2AB399FABB280E01006EC36FFC70429B4EAE1875321A4609670078C4FA00320000")
' Set initial value of i to 0
i = 0
' Repeat deleting function 10 times to make sure all apointments have been cleared from the folder.
Do Until i = 10
CheckAppointment = False
' For each of the "objects" appointments and other in the folder specified above repeat the loop.
' Beacause not all of the objects are appointments it sometimes ends to early,
' which is why it runs 10 times. (Easier than coding a more stringent code, and really not the
' resource demanding).
For Each oObject In oFolder.Items
' Compare each object to appoint class and delete objects where match is found.
If oObject.Class = olAppointment Then
Set oApptItem = oObject
oApptItem.Delete
End If
' Repeat for each object/item.
Next oObject
' Rinse and repeat.
i = i + 1
Loop
' Clear variables
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing
End Sub
Eine Unterroutine löscht den freigegebenen Kalender. Dann lädt die Hauptroutine die neuen Daten hoch. Schließlich schließt eine Subroutine die Arbeitsmappe.
Wenn jemand irgendwelche Vorschläge zur Reinigung hat, lass es mich wissen.
Danke!
Außerdem ist here ein Bild der Excel-Tabelle, die ich verwende.
Gibt es in der E-Mail etwas anderes als die Tabelle, d. H. Müssen Sie die Tabelle von anderen Dingen trennen oder ist die Tabelle der gesamte E-Mail-Text? –
Wir wissen nicht, was Ihr HR-System ist und was es kann. Wenn jeder Benutzer Outlook mit Exchange verwendet, besteht eine Möglichkeit darin, einen öffentlichen Kalender zu erstellen, beispielsweise "Staffs On Leave". Dann lassen Sie sie ihre Off-Zeiten einstellen, damit jeder sehen kann, wer ausgeschaltet ist. – PatricK
@DickKusleika Ich habe eine Menge Kontrolle darüber, wie die E-Mail aussieht. Momentan sieht es so aus (http://i.imgur.com/rY1L4uw.jpg). –