Boa noite, poderiam me ajudar no código abaixo, na parte onde tem o updateitem ele dá um erro de variavel with o que tenho que fazer ??
Obrigado,
Rafael
Dim PERGUNTA, PERGUNTA2, PERGUNTA3, PERGUNTA4, PERGUNTA5, PERGUNTA6, PERGUNTA7, DECISAO, DECISAO2, DECISAO3, DECISAO4, DECISAO5, DECISAO6, DECISAO7
Dim OL As Outlook.Application
Dim olAppt As TaskItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As TaskItem
Dim r As Long, sSubject As String, sBody As String
Dim dStartDate As Date, dDueDate As Date
Dim sSearch As String, bOLOpen As Boolean
Dim s As Worksheet
On Error Resume Next
Set OL = GetObject("Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderTasks).Items
PERGUNTA = "DIGITE O ASSUNTO:"
DECISAO = InputBox(PERGUNTA)
PERGUNTA2 = "DIGITE O DATA INICIO:"
DECISAO2 = InputBox(PERGUNTA2)
PERGUNTA3 = "DIGITE O HORA INICIO:"
DECISAO3 = InputBox(PERGUNTA3)
PERGUNTA4 = "DIGITE O HORA TÉRMINO:"
DECISAO4 = InputBox(PERGUNTA4)
PERGUNTA5 = "DIGITE O LOCAL:"
DECISAO5 = InputBox(PERGUNTA5)
PERGUNTA6 = "DIGITE A CATEGORIA:"
DECISAO6 = InputBox(PERGUNTA6)
PERGUNTA7 = "DIGITE O CORPO DA MENSAGEM:"
DECISAO7 = InputBox(PERGUNTA7)
For r = 2 To 5
If Len(Worksheets("Outlook").Cells(r, 1).Value) = 0 Then GoTo NextRow
If DECISAO <> "" Then
If Worksheets("Outlook").Cells(r, 1).Value = Texttitulo Then
Worksheets("Outlook").Cells(r, 1).Value = DECISAO
sSubject = Worksheets("Outlook").Cells(r, 1).Value
End If
If DECISAO2 <> "" Then
Worksheets("Outlook").Cells(r, 2).Value = DECISAO2
dStartDate = Worksheets("Outlook").Cells(r, 2).Value
Worksheets("Outlook").Cells(r, 4).Value = DECISAO2
dDueDate = Worksheets("Outlook").Cells(r, 4).Value
End If
If DECISAO3 <= "23:59" Then
Worksheets("Outlook").Cells(r, 3).Value = DECISAO3
dStartTIME = Worksheets("Outlook").Cells(r, 3).Value
End If
If DECISAO4 < "23:59" Then
Worksheets("Outlook").Cells(r, 5).Value = DECISAO4
dDueTIME = Worksheets("Outlook").Cells(r, 5).Value
End If
If DECISAO6 <> "" Then
Worksheets("Outlook").Cells(r, 6).Value = DECISAO6
dCATEGORIES = Worksheets("Outlook").Cells(r, 6).Value
End If
If DECISAO5 <> "" Then
Worksheets("Outlook").Cells(r, 7).Value = DECISAO5
dLOCATION = Worksheets("Outlook").Cells(r, 7).Value
End If
If DECISAO7 <> "" Then
Worksheets("Outlook").Cells(r, 8).Value = DECISAO7
dBODY = Worksheets("Outlook").Cells(r, 8).Value
End If
End If
sSubject = Worksheets("OUTLOOK").Cells(r, 1).Value
dStartDate = Worksheets("OUTLOOK").Cells(r, 2).Value
dDueDate = Worksheets("OUTLOOK").Cells(r, 4).Value
dStartTIME = Worksheets("OUTLOOK").Cells(r, 3).Value
dDueTIME = Worksheets("OUTLOOK").Cells(r, 5).Value
dLOCATION = Worksheets("OUTLOOK").Cells(r, 6).Value
dCATEGORIES = Worksheets("OUTLOOK").Cells(r, 7).Value
dBODY = Worksheets("OUTLOOK").Cells(r, 8).Value
sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)
'If olApptSearch Is Nothing Then
' Set olAppt = OL.CreateItem(olTaskItem)
' olAppt.subject = sSubject
' olAppt.StartDate = dStartDate
' olAppt.DueDate = dDueDate
'olAppt.StartTime = dStartTIME
'olAppt.DueTIME = dDueTIME
'olAppt.Location = dLOCATION
'olAppt.Categories = dCATEGORIES
'olAppt.Body = dBODY
'olAppt.Close olSave
'End If
If RESP <> "1" Then
Set olApptSearch = colItems.Find(sSearch)
If olAppt.subject = Texttitulo Then
Set olAppt = OL.updateitem(olTaskItem)
olAppt.subject = sSubject
olAppt.StartDate = dStartDate
olAppt.DueDate = dDueDate
olAppt.StartTime = dStartTIME
olAppt.DueTIME = dDueTIME
olAppt.Categories = dCATEGORIES
olAppt.Location = dLOCATION
olAppt.Body = dBODY
olAppt.Close olSave
End With
End If
End If
NextRow:
Next r
If bOLOpen = False Then OL.Quit
End Sub
Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function
Postado : 27/04/2015 6:29 pm