Få excel til et oprette Outlook-taks der sendes til en kollega.
Med referece til et tidligere spørgsmål http://www.eksperten.dk/spm/1010028 der nu er afsluttet, så opretter min excel-VBA-automatisering nogle tasks i min egen Outlook.Jeg lavede en løsning kraftigt inspireret en det jeg fandt på mrexcelguru.com:
På siden http://mrexcelguru.com/create-tasks-in-outlook-from-excel/ er der et link til en fil der kan hentes ned, og den hjalp mig med en løsning der virker.
Jeg poster lige koden her også:
Bemærk at den er delt i to procedurer og én function der kalder hinanden.
Dim bWeStartedOutlook As Boolean
Sub Transfer()
Dim BatchNrCol As Integer
Dim BatchEndDateCol As Integer ' variabel til hvilken kolonne har jeg batchenes slutdatoer
Dim TaskCreatedCol As Integer ' variabel til hvilken kolonne vil jeg markere at OutlookTask er genereret
Dim TaskSubjectStr As String
Dim BatchStr As String
Dim DueDate As Date
BatchNrCol = 1
BatchEndDateCol = Cells(1, SLUTDATOER_ML).Column + 2
TaskCreatedCol = BatchEndDateCol + 15
RowNr = FindActualBatch("I") ' jeg kalder en function der finder rækken med den igangværende batch.
BatchStr = Cells(RowNr, BatchNrCol)
DueDate = Cells(RowNr, BatchEndDateCol).Value
' tjekker om der allerede er oprettet task
If Not Cells(RowNr, TaskCreatedCol).Value = "OutlookTask Created" Then
' hvis ikke så opretter vi en task
TaskSubjectStr = "Kontroller slutprøver fra IA-batch " & BatchStr & ", og bestil rengøringshold til næste gang"
Cells(RowNr, TaskCreatedCol).Value = "OutlookTask Created"
Call AddTask(TaskSubjectStr, DueDate)
End If
End Sub
Sub Transfer()
Dim BatchNrCol As Integer
Dim BatchEndDateCol As Integer ' variabel til hvilken kolonne har jeg batchenes slutdatoer
Dim TaskCreatedCol As Integer ' variabel til hvilken kolonne vil jeg markere at OutlookTask er genereret
Dim TaskSubjectStr As String
Dim BatchStr As String
Dim DueDate As Date
BatchNrCol = 1
BatchEndDateCol = Cells(1, SLUTDATOER_ML).Column + 2
TaskCreatedCol = BatchEndDateCol + 15
RowNr = FindActualBatch("I") ' jeg kalder en function der finder rækken med den igangværende batch.
BatchStr = Cells(RowNr, BatchNrCol)
DueDate = Cells(RowNr, BatchEndDateCol).Value
' tjekker om der allerede er oprettet task
If Not Cells(RowNr, TaskCreatedCol).Value = "OutlookTask Created" Then
' hvis ikke så opretter vi en task
TaskSubjectStr = "Kontroller slutprøver fra IA-batch " & BatchStr & ", og bestil rengøringshold til næste gang"
Cells(RowNr, TaskCreatedCol).Value = "OutlookTask Created"
Call AddTask(TaskSubjectStr, DueDate)
End If
End Sub
Sub AddTask(sString As String, dDueDate As Date)
Dim olApp As Object
Dim objTask As Object
'Start Outlook if not started
On Error Resume Next ' deaktverer fejlmedd.
Set olApp = GetOutlookApp ' funktionskald der tjekker om outlook er åben - ellers åbner vi outlook
On Error GoTo 0
If Not olApp Is Nothing Then
Set objTask = olApp.CreateItem(3) ' generer en ny Task
With objTask ' sætter nogle egenskaber i task'en
.StartDate = dDueDate ' startdato - bruger samme som slutdato
.DueDate = dDueDate
.Subject = sString
.Save ' springer diaplay over og går direkte til gem
End With
End If
If bWeStartedOutlook Then
olApp.Quit
End If
Set olApp = Nothing
Set objTask = Nothing
End Sub
Dim olApp As Object
Dim objTask As Object
'Start Outlook if not started
On Error Resume Next ' deaktverer fejlmedd.
Set olApp = GetOutlookApp ' funktionskald der tjekker om outlook er åben - ellers åbner vi outlook
On Error GoTo 0
If Not olApp Is Nothing Then
Set objTask = olApp.CreateItem(3) ' generer en ny Task
With objTask ' sætter nogle egenskaber i task'en
.StartDate = dDueDate ' startdato - bruger samme som slutdato
.DueDate = dDueDate
.Subject = sString
.Save ' springer diaplay over og går direkte til gem
End With
End If
If bWeStartedOutlook Then
olApp.Quit
End If
Set olApp = Nothing
Set objTask = Nothing
End Sub
Function GetOutlookApp() As Object
' function tjekker om Outlook er åben ellers åbner vi Outlook
On Error Resume Next
Set GetOutlookApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set GetOutlookApp = CreateObject("Outlook.Application")
bWeStartedOutlook = True
End If
On Error GoTo 0
End Function
' function tjekker om Outlook er åben ellers åbner vi Outlook
On Error Resume Next
Set GetOutlookApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set GetOutlookApp = CreateObject("Outlook.Application")
bWeStartedOutlook = True
End If
On Error GoTo 0
End Function
Spørgsmål:
Kan jeg lave en udgave der sender den oprettede Task til en kolega ?
