vba to send calendar appointments rather then emails

[Tej92]

Hello all, I'm trying to get this code to send appointments with the task to carry out but having trouble, tried multiple solutions from the web, I managed to send them but it was requiring outlook to be open but i'd like to use CDO to send them as i did for the emails.
Currently it sends the week number as when to do the task by looking at the value selected in b12, now i want it to calculate the dates by getting the week number and send the invite from Monday to Friday of that week and it should make this invite a non-busy appointment.
the body of the current message should be the body of the appointment too.

Private Sub CommandButton1_Click()
Dim Pass As String
Pass = "1234"

If InputBox("Please enter the password to run the macro") <> Pass Then
MsgBox "Incorrect password!", vbExclamation, "Error"
Exit Sub
End If

Dim objMail As Object
Set objMail = CreateObject("CDO.Message")

With objMail.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "xxxxsmtpxx.server.xxxx.xx"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With

Dim weekNumber As Variant
weekNumber = Range("B12").Value

Dim weekColumn As Long
weekColumn = 0
For i = 2 To 35
If Cells(13, i).Value = weekNumber Then
weekColumn = i
Exit For
End If
Next i

If weekColumn = 0 Then
MsgBox "Week " & weekNumber & " not found in range B13:AI13.", vbCritical, "Error"
Exit Sub
End If

Dim recipientRange As Range
Set recipientRange = Range(Cells(14, weekColumn), Cells(Rows.Count, weekColumn).End(xlUp))

Dim recipient As Range
Dim totalRecipients As Long
totalRecipients = recipientRange.Cells.Count

Dim sentCount As Long
sentCount = 0

Dim progressBar As String
Dim progressPercentage As Double
Dim progressLength As Integer
progressLength = 30 ' Length of the progress bar

For Each recipient In recipientRange
If recipient.Value <> "" Then
Dim areaName As String
areaName = Range("A" & recipient.Row).Value

Dim recipientEmail As String
recipientEmail = Application.WorksheetFunction.VLookup(recipient.Value, Range("AV:AW"), 2, False)

objMail.To = recipientEmail
objMail.From = "noreply@xxxxxx.co.uk"
objMail.Subject = "task Reminder for " & areaName
objMail.TextBody = Sheet9.Range("message_body").Value & Sheet9.Range("B12").Value & " in the " & areaName & " area." & vbNewLine & Sheet9.Range("message_body2").Value
objMail.Send

sentCount = sentCount + 1
progressPercentage = sentCount / totalRecipients
progressBar = String(progressLength, "=") & " " & Format(progressPercentage, "0%")

Application.StatusBar = "Sending Emails: " & progressBar
DoEvents ' Allow the status bar to update

Else
MsgBox "Empty cell found in recipient list. Stopping email sending process.", vbCritical, "Error"
Set objMail = Nothing ' Release the email object before exiting the subroutine
Application.StatusBar = False ' Clear the status bar
Exit Sub ' Exit the subroutine when an empty cell is found
End If
Next recipient

Application.StatusBar = False ' Clear the status bar
Set objMail = Nothing

MsgBox "task reminder email sent for week " & weekNumber & ".", vbInformation, "Success"
End Sub



Any help will be greatly appreciated.

 

[Tej92]

any help will be greatly appreciated!