Hi
i've been using this code to send a teams invitation till now (dunno actually when it stopped to work) , but now when outlook opens the "send from" is blank and i cannot chose the correct my email (i can if i start a new meeting manually)
code:
Code:
Public Function CreateAppt(Richiesto As Recordset, DataInizio As Date, Subj, MailFrom As String, BodyTXT, Inizio, Fine As String, Teams As Boolean, Optional Ind As String, Optional Opzionale As Recordset, Optional Risorsa As Recordset) Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim m As Outlook.MailItem
Dim oAccount As Outlook.Account
Dim txt As String
Dim myRequiredAttendee, myOptionalAttendee, myResourceAttendee As Outlook.Recipient
Set olApp = GetObject("", "Outlook.Application")
For Each oAccount In olApp.Session.Accounts 'Application.Session.Accounts <<Application in this context refers to Access not Outlook>>
If oAccount = MailFrom Then
Set m = olApp.CreateItem(olMailItem) 'creo mail per formnattazione html non presente in meeting
Set olAppItem = olApp.CreateItem(olAppointmentItem)
With olAppItem
.MeetingStatus = olMeeting
.SUBJECT = Subj
.Location = Ind
.Start = FormatDateTime(DataInizio & " " & Inizio) '#9/24/2009 1:30:00 PM#
'.Body = BodyTXT ' utilizzo l'oggetto mail sotto
.Duration = (Left(Fine, 2) - Left(Inizio, 2)) * 60 + Right(Fine, 2) - Right(Inizio, 2)
.ReminderMinutesBeforeStart = 15
.ResponseRequested = True
.SendUsingAccount = oAccount
If Teams Then 'se non è una teams inserisco anche il luogo
Else
.Location = Ind
End If
End With
Do Until Richiesto.EOF
Set myRequiredAttendee = olAppItem.Recipients.Add(Richiesto!Email)
myRequiredAttendee.Type = olRequired
Richiesto.MoveNext
Loop
If Not Opzionale Is Nothing Then
Do Until Opzionale.EOF
Set myOptionalAttendee = olAppItem.Recipients.Add(Opzionale!Email)
myRequiredAttendee.Type = olOptional
Opzionale.MoveNext
Loop
End If
If Not Risorsa Is Nothing Then
Do Until Risorsa.EOF
Set myResourceAttendee = olAppItem.Recipients.Add(Risorsa!Email)
myRequiredAttendee.Type = olResource
Risorsa.MoveNext
Loop
End If
olAppItem.Display
' m.BodyFormat = olFormatHTML ' dopo il display setto l'oggetto mail al formato html
' m.HTMLBody = BodyTXT
' m.GetInspector().WordEditor.Range.FormattedText.Copy 'setto il corpo della mail al testo che ho selezionato
' olAppItem.GetInspector().WordEditor.Range.FormattedText.Paste 'setto il corpo della mail al testo che ho selezionato
If IDCalendarioVideo <> "" Then
DoCmd.SetWarnings False
DoCmd.RunSQL ("UPDATE Calendario SET Calendario.IDvideo =""" & olAppItem.GlobalAppointmentID & """ WHERE (((Calendario.IDCalendario)=" & IDCalendarioVideo & "));")
IDCalendarioVideo = ""
DoCmd.SetWarnings True
End If
If Teams Then
SendKeys "{F10}", True 'rende visibili i tasti rapidi
'Switch to ribbon shortcuts
SendKeys "H", True 'SendKeys "%H", True
'Hit the Microsoft teams meetings button, requires teams to be installed
SendKeys "TM", True
End If
End If
Next
'olAppItem.Send
End Function