VBA code outlook uitbreiden (body bereik cellen)

Status
Niet open voor verdere reacties.

Bruggemanmark

Gebruiker
Lid geworden
29 sep 2014
Berichten
21
Beste mensen,

Heb op dit forum een bestandje gedownload welke automatisch vanuit excel een taak in outlook vermeld met
omschrijving e.d. Nu wil ik graag dat er bij de omschrijving een extra kolom wordt toegevoegd. Er is nu een kolom met body,
dit moeten er eigenlijk 6 worden. Als ik dit verander krijg ik een foutmelding. Welke code moet ik toevoegen om bijvoorbeeld
kolom J t/m O toe te voegen.

Dit is de code nu:

Private Sub CommandButton1_Click()

Dim blnOutlookQuit As Boolean
Dim lngRow As Long
Dim objFolder As Object
Dim objNamespace As Object
Dim objOutlook As Object
Dim objTask As Object

On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
blnOutlookQuit = True
Set objOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(13)
objFolder.Display 'laat folder zien anders foutmelding door remindertime

With Worksheets(1)
For lngRow = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
Set objTask = objOutlook.CreateItem(3)
With objTask
.Subject = CStr(Cells(lngRow, 2).Value)
.StartDate = CDate(Cells(lngRow, 3).Value)
.DueDate = CDate(Cells(lngRow, 4).Value)
.Status = CInt(Cells(lngRow, 5).Value) 'olTaskComplete 2, olTaskDeferred 4, olTaskInProgress 1,olTaskNotStarted 0, olTaskWaiting 3
.Importance = CInt(Cells(lngRow, 6).Value) 'olImportanceHigh 2, olImportanceLow 0, olImportanceNormal 1
.PercentComplete = CInt(Cells(lngRow, 7).Value) '0 ... 100 stuurt mogelijk status
.ReminderSet = CBool(Cells(lngRow, 8).Value) 'true false
.ReminderTime = CDate(Cells(lngRow, 9).Value) 'date and time
.Body = CStr(Cells(lngRow, 10).Value)
.Save
End With
Next
End With

If blnOutlookQuit Then
objOutlook.Quit
End If

Set objTask = Nothing
Set objFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing

End Sub


Alvast bedankt.
 
Code:
.Body = CStr(Cells(lngRow, 10).Resize(,5).Value)
 
Bedankt voor de snelle reactie,

Alleen werkt de code niet. Heb even het bestandje toegevoegd wellicht dat dat meer duidelijkheid geeft.
 

Bijlagen

  • worksheet outlook.xls
    43 KB · Weergaven: 61
en zo?
Code:
Option Explicit

Private Sub CommandButton1_Click()
Dim a
Dim T As String
Dim i As Integer
Dim blnOutlookQuit As Boolean
Dim lngRow As Long
Dim objFolder As Object
Dim objNamespace As Object
Dim objOutlook As Object
Dim objTask As Object

On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
    blnOutlookQuit = True
    Set objOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(13)
objFolder.Display 'laat folder zien anders foutmelding door remindertime

With Worksheets(1)
    For lngRow = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
     a = .Cells(lngRow, 10).Resize(, 5)
     T = ""
      For i = 1 To 5
       T = T & " " & a(1, i)
      Next
        Set objTask = objOutlook.CreateItem(3)
        With objTask
            .Subject = CStr(Cells(lngRow, 2).Value)
            .StartDate = CDate(Cells(lngRow, 3).Value)
            .DueDate = CDate(Cells(lngRow, 4).Value)
            .Status = CInt(Cells(lngRow, 5).Value) 'olTaskComplete 2, olTaskDeferred 4, olTaskInProgress 1,olTaskNotStarted 0, olTaskWaiting 3
            .Importance = CInt(Cells(lngRow, 6).Value) 'olImportanceHigh 2, olImportanceLow 0, olImportanceNormal 1
            .PercentComplete = CInt(Cells(lngRow, 7).Value) '0 ... 100 stuurt mogelijk status
            .ReminderSet = CBool(Cells(lngRow, 8).Value) 'true false
            .ReminderTime = CDate(Cells(lngRow, 9).Value) 'date and time
            .Body = T
            .Save
        End With
    Next
End With

If blnOutlookQuit Then
    objOutlook.Quit
End If

Set objTask = Nothing
Set objFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing

End Sub

of als je ze onder elkaar wilt
Code:
 T = T & " " & a(1, i) & vbLf
 
Laatst bewerkt:
En als ik de melding niet in Outlook Taak wil hebben maar in een gedeelde Outlook Agenda wat dien ik dan aan te passen.
Kom er namelijk niet uit.
 
Heb een code gevonden/ gemaakt waar de afspraken in de agenda komen en ook geen dubbele afspraken worden gemaakt.
Alleen kom de afspraak in de standaard agenda. Wie kan mij helpen om dit om te zetten naar een gedeelde agenda.
Dit is de code.

Code:
Sub SetAppt()
 
Dim olApp As New Outlook.Application
Dim olApt As AppointmentItem
Dim Ddatum As Date
Dim sFind As String
Dim ns As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim Appt As Outlook.AppointmentItem
Dim lRij As Long
    
    Set ns = olApp.GetNamespace("MAPI")
    lRij = 2
    While ActiveSheet.Range("A" & lRij) <> ""
        sFind = "[Start] = '" & Format(ActiveSheet.Range("A" & lRij).Value + ActiveSheet.Range("D" & lRij).Value, "ddddd h:mm") & "' AND [Subject]='" & ActiveSheet.Range("B" & lRij) & "'"
        
        Set olFolder = ns.GetDefaultFolder(olFolderCalendar)
        Set Appt = olFolder.Items.Find(sFind)
    
        Set olApp = New Outlook.Application
        Set olApt = olApp.CreateItem(olAppointmentItem)

        If Appt Is Nothing Then
            Set Appt = olFolder.Items.Add
            With Appt
                .Start = ActiveSheet.Range("A" & lRij).Value + ActiveSheet.Range("D" & lRij).Value
                .End = ActiveSheet.Range("A" & lRij).Value + ActiveSheet.Range("E" & lRij).Value
                .Subject = ActiveSheet.Range("B" & lRij).Value
                .Location = ActiveSheet.Range("C" & lRij).Value
                .Body = ActiveSheet.Range("F" & lRij).Value + vbCrLf + ActiveSheet.Range("G" & lRij).Value + vbCrLf + ActiveSheet.Range("H" & lRij).Value + vbCrLf + ActiveSheet.Range("I" & lRij).Value + vbCrLf
                .Save
            End With
        End If
        lRij = lRij + 1
    Wend
    Set olApt = Nothing
    Set olApp = Nothing
 
End Sub

Alvast bedankt
 
Als ik code aanpas naar de link werkt deze niet. Geeft aan Syntas fout.

Heb ook al gepuzzeld met default folder aan passen naar shared default folder dan geeft hij
aan de naam van de agenda aan en = leeg.
 
Heb even een tijd gepuzzeld maar of een foutmelding of gewoon in de standaard agenda.
Kom er niet uit. Wie kan mij op weg helpen.

Alvast bedankt.
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan