set teams meeting

[diegomarino]

hi, i'd like to create a meeting on teams, i found this stuff but it doesn't work, the part of hitting teams button and "richiesto" recordsett seems to be infinite

Sub CreateAppt(Richiesto As Recordset, DataInizio As Date, Subj, 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 myRequiredAttendee, myOptionalAttendee, myResourceAttendee As Outlook.Recipient
   
   Set olApp = GetObject("", "Outlook.Application")
   Set olAppItem = olApp.CreateItem(olAppointmentItem)
   olAppItem.MeetingStatus = olMeeting
   olAppItem.SUBJECT = Subj
   olAppItem.Location = Ind
   olAppItem.Start = FormatDateTime(DataInizio & " " & Inizio) '#9/24/2009 1:30:00 PM#
   olAppItem.Duration = 1 '(Left(Fine, 2) - Left(Inizio, 2) * 60) + Right(Fine, 2) - Right(Inizio, 2)
   
   Do Until Richiesto.EOF
      Set myRequiredAttendee = olAppItem.Recipients.Add(Richiesto!Email)
      myRequiredAttendee.Type = olRequired
   Loop
   
   Do Until Opzionale.EOF
      Set myOptionalAttendee = olAppItem.Recipients.Add(Opzionale!Email)
      myRequiredAttendee.Type = olOptional
   Loop
   
   Do Until Risorsa.EOF
      Set myResourceAttendee = olAppItem.Recipients.Add(Risorsa!Email)
      myRequiredAttendee.Type = olResource
   Loop
   If Teams Then
      SendKeys "{F10}", True
      'Switch to ribbon shortcuts
      SendKeys "H", True
      'Hit the Microsoft teams meetings button, requires teams to be installed
      SendKeys "TM", True
   End If
   olAppItem.Display
   'olAppItem.Send
End Sub

thanks

[CJ_London]

looks like you are missing a .movenext in each of your loops

[diegomarino]

sure.
i tried this one and it works except that the body is not html fornatted, how can i do that? in another function i use to make emails i have HTMLbody, here is no available

and moreover, it is a teams meeting without i have to specify that, how can i make a presence meeting?

Sub CreateAppt(Richiesto As Recordset, DataInizio As Date, Subj, 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 myRequiredAttendee, myOptionalAttendee, myResourceAttendee As Outlook.Recipient
   
   Set olApp = GetObject("", "Outlook.Application")
   Set olAppItem = olApp.CreateItem(olAppointmentItem)
   With olAppItem
      .MeetingStatus = olMeeting
      .SUBJECT = Subj
      .Location = Ind
      .Start = FormatDateTime(DataInizio & " " & Inizio) '#9/24/2009 1:30:00 PM#
      .BodyFormat = olFormatHTML
      .Body = BodyTXT
      .Duration = (Left(Fine, 2) - Left(Inizio, 2)) * 60 + Right(Fine, 2) - Right(Inizio, 2)
      .ReminderMinutesBeforeStart = 15
      
   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
'   If Teams Then
'      SendKeys "{F10}", True
'      'Switch to ribbon shortcuts
'      SendKeys "%H", True
'      'Hit the Microsoft teams meetings button, requires teams to be installed
'      SendKeys "TM", True
'   End If
   'olAppItem.Send
End Sub

[CJ_London]

Not sure what you are asking - your code is about adding emails

edit:

I would look at these two lines

.BodyFormat = olFormatHTML
.Body = BodyTXT

BodyText needs to be formatted as html

or change the bodyformat to plaintext or richtext

[diegomarino]

Tried, but it is not working unfortunately. It just change something, like line break if I'm not wrong.

Then, why this meeting is by default teams?

[CJ_London]

I have no idea - it’s your code.

[diegomarino]

found the soplution. you have to create another mail object that can be formatted in html, then copy and paste in appointment object.

Sub CreateAppt(Richiesto As Recordset, DataInizio As Date, Subj, 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 Txt As String
   Dim myRequiredAttendee, myOptionalAttendee, myResourceAttendee As Outlook.Recipient
   
   Set olApp = GetObject("", "Outlook.Application")
   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


      
   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
   'olAppItem.Send
End Sub

if you don't want default meeting as default you have to do that

https://businesstechplanet.com/how-t...e%E2%80%9D.%20