Convert VBA Code Designed for Windows To Run On A Mac

[Runninrep]

I have a code that works well to send e-mails from Excel based on certain criteria when run. It was designed for Windows. I also need it to run on a Mac. Can anyone explain what needs to change in order to do this? My understanding is that I get an "error 429: Active X component can't create object" because Mac doesn't recognize Active X and therefore won't connect to Outlook.

I keep trying to post the code here, but the system keeps denying it, says it has too many URL's or bad words, but there are neither in the code. How else can I provide the current code I have?

Thanks in advance for your help.

[Aussiebear]

Here is your code

Sub Send_Email()
    Dim OutApp as Object, OutMail As Object
    Dim lLastRow as Long, lRow as Long
    Dim sSendTo as String, sSendCC as String, sSendBCC as String
    Dim sSubject as String, sTemp as String
    On Error goto errHandler
    SetOutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    ' Change the following as needed
    sSendTo = "Michael@lafamilialf.com"
    sSendCC = "mrempel@excel-bytes.Com"
    sSubject = "Project Past Due!"
    lLastRow = Cells(Rows.Count,1).End(xlUp).Row
    For lRow = 2 to lLastRow
        If Cells(lRow ,4)<>"Completed" Then
            If Cells(lRow,2)<=Date Then
                SetOutMail = OutApp.CreateItem(0)
                ' On Error Resume Next
                With OutMail
                     .To = sSendTo
                     If sSendCC > " " Then .CC = sSendCC
                     If sSendBCC > " " Then .BCC = sSendBCC
                     .Subject = sSubject
                     sTemp ="Hello!" & vbCrLf & vbCrLf
                     sTemp = sTemp & "The due date has passed fro this project: " & vbCrLf & vbCrLf
                    ' Assumes project name is in Column B
                    sTemp & " " & Cells(lRow,1) & vbCrLf & vbCrLf
                    sTemp = sTemp & "Please take appropriate action." & vbCrLf & vbCrLf
                    s temp = sTemp & "Thank You!" & vbCrLf
                    .Body = sTemp
                    ' Change the following to.Send if you want to send the message without reviewing first .Send
                    .Send
                End With
                Set OutMail = Nothing
                Cells(lRow,6) = "E-mail sent on: " & Now()
           End if
       End If
    Next lRow
    exitHere:
    Set OutApp = Nothing
    Exit Sub
    errHandler:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume exitHere
End Sub

[Aussiebear]

Just two changes I'd make initially and then we'll wait for someone to review this code

Sub Send_Email()
    Dim OutApp as Object, OutMail As Object
    Dim lLastRow as Long, lRow as Long
    Dim sSendTo as String, sSendCC as String, sSendBCC as String
    Dim sSubject as String, sTemp as String
    On Error goto errHandler
    SetOutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    ' Change the following as needed
    sSendTo = "Michael@lafamilialf.com"
    sSendCC = "mrempel@excel-bytes.Com"
    sSubject = "Project Past Due!"
    lLastRow = Cells(Rows.Count,1).End(xlUp).Row
    For lRow = 2 to lLastRow
        If Cells(lRow ,4)<>"Completed" Then
           If Cells(lRow,2)<=Date Then
              SetOutMail = OutApp.CreateItem(0)
              ' On Error Resume Next
              With OutMail
                  .To = sSendTo
                  If sSendCC > " " Then .CC = sSendCC
                  If sSendBCC > " " Then .BCC = sSendBCC
                       .Subject = sSubject
                       sTemp ="Hello!" & vbCrLf & vbCrLf
                       sTemp = sTemp & "The due date has passed fro this project: " & vbCrLf & vbCrLf
                       'Assumes project name is in Column B
                       sTemp & " " & Cells(lRow,1) & vbCrLf & vbCrLf
                       sTemp = sTemp & "Please take appropriate action." & vbCrLf & vbCrLf
                       s temp = sTemp & "Thank You!" & vbCrLf
                       .Body = sTemp
                       ' Change the following to.Send if you want to send the message without reviewing first .Send
                       .Send
                    End If
                 End If
              End With
              Set OutMail = Nothing
              Cells(lRow,6) = "E-mail sent on: " & Now()
           End if
       End If
    Next lRow
    exitHere:
    Set OutApp = Nothing
    Exit Sub
    errHandler:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume exitHere
End Sub

[Aussiebear]

Just had a quick look at something similar from Ron DeBruin at learn.microsoft.com

Sub Mail_Selection_In_Excel2011()'For Excel 2011 for the Mac and Apple Mail
    Dim Source As Range
    Dim Destwb As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    If Val(Application.Version) < 14 Then Exit Sub
    Set Source = Nothing
    On Error Resume Next
    Set Source = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, " & _
               "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    If ActiveWindow.SelectedSheets.Count > 1 Or _
       Selection.Cells.Count = 1 Or _
       Selection.Areas.Count > 1 Then
        MsgBox "An Error occurred :" & vbNewLine & vbNewLine & _
               "You have more than one sheet selected." & vbNewLine & _
               "You only selected one cell." & vbNewLine & _
               "You selected more than one area." & vbNewLine & vbNewLine & _
               "Please correct and try again.", vbOKOnly
        Exit Sub
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set wb = ActiveWorkbook
    Set Destwb = Workbooks.Add(xlWBATWorksheet)
    Source.Copy
    With Destwb.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    'Save format and extension
    FileExtStr = ".xlsx": FileFormatNum = 52
    ' Or if you want it in xls format, use:
    ' FileExtStr = ".xls": FileFormatNum = 57
    ' Save the new workbook, mail it, and delete it.
    'If you want to change the file name then change only TempFileName
    TempFilePath = MacScript("return (path to documents folder) as string")
    TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        MailFromMacWithMail bodycontent:="Hi there", _
        mailsubject:="Mail Selection Test", _
        toaddress:="ron@debruin.nl", _
        ccaddress:="", _
        bccaddress:="", _
        attachment:=.FullName, _
        displaymail:=False
       .Close SaveChanges:=False
    End With
    KillFileOnMac TempFilePath & TempFileName & FileExtStr
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Perhaps this may give you some ideas. Notice that he doesn't use vbCrLf but vbNewLine.

[Runninrep]

Microsoft Outlook for Mac is not scriptable using Visual Basic for Applications. You have to use AppleScript, which you can launch using MacScript within VBA.Aussiebear, thanks for getting my code onto the forum. Do you have any idea why I was getting messages saying that it would not post because it had too may URL's or not acceptable language?

I am also told that Microsoft Outlook for Mac is not scriptable using Visual Basic for Applications. You have to use AppleScript, which you can launch using MacScript within VBA. I am a little familiar with VBA, just enough to get me in trouble, but am not at all familiar with MacSrcipt, so I'm not sure where to start. But thank you very much for the work you did on this.

[Aussiebear]

Not high enough post count I'm assuming. Admin have their rules.

[ScratchSmart]

I'm having the same issue. Can anyone help?

Sub GenerateCSVFiles()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim csvContent As String
    Dim gameName As String
    Dim myFile As String
    Dim fNum As Integer
    Dim dict As Object
    Dim itemCounter As Long
    Dim csvFolderPath As String
    Set dict = CreateObject("Scripting.Dictionary")
    ' Disable screen updating and alerts to improve performance and prevent pop-up messages
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ' Set the worksheet where your data resides
    Set ws = ThisWorkbook.Sheets("Sheet1")
    csvFolderPath = ThisWorkbook.Path & "\CSV_Files"
    If Dir(csvFolderPath, vbDirectory) = "" Then
         MkDir csvFolderPath
    End If
    ' Find the last row with data in column D (assuming this is where game_name is)
    lastRow = ws.Cells(ws.Rows.Count, "Q").End(xlUp).Row
    ' Loop through all the rows to collect unique game names
    For i = 2 To lastRow
         If Not IsEmpty(ws.Cells(i, 4).Value) Then
             gameName = ws.Cells(i, 4).Value
             If Not dict.Exists(gameName) Then
                  dict.Add gameName, True
             End If
         End If
    Next i
    ' Process each unique game name
    Dim key As Variant
    For Each key In dict.Keys
         gameName = key
         gameRow = 0
         ' Sanitize the gameName to create a valid filename
         sanitizedGameName = Replace(gameName, " ", "_")
         sanitizedGameName = Replace(sanitizedGameName, "\", "_")
         sanitizedGameName = Replace(sanitizedGameName, "/", "_")
         sanitizedGameName = Replace(sanitizedGameName, ":", "_")
         sanitizedGameName = Replace(sanitizedGameName, "*", "_")
         sanitizedGameName = Replace(sanitizedGameName, "?", "_")
         sanitizedGameName = Replace(sanitizedGameName, Chr(34), "_") ' Double quotes
         sanitizedGameName = Replace(sanitizedGameName, "<", "_")
         sanitizedGameName = Replace(sanitizedGameName, ">", "_")
         sanitizedGameName = Replace(sanitizedGameName, "|", "_")
         sanitizedGameName = Replace(sanitizedGameName, "&", "and")
         sanitizedGameName = Replace(sanitizedGameName, ",", "")
         sanitizedGameName = Replace(sanitizedGameName, "#", "Number")
         ' Ensure the filename is not too long
         If Len(sanitizedGameName) > 200 Then ' Limit to 200 to leave room for date and extension
             sanitizedGameName = Left(sanitizedGameName, 200)
         End If
         ' Find the row number for the current gameName
         For i = 2 To lastRow
              If ws.Cells(i, 4).Value = gameName Then
                   gameRow = i
                   Exit For
              End If
          Next i
          If gameRow > 0 Then
              ' Initialize the CSV content with the main headers
              csvContent= "name,IMAGE,TOTAL_TICKETS,TOTAL_TICKETS_COLOR,TOTAL_TICKETS_TEXT,TOTAL_LOSING, _
              TOTAL_LOSING_COLOR,TOTAL_LOSING_TEXT,TOTAL_WINNINGS,TOTAL_WINNINGS_COLOR, _
              TOTAL_WINNINGS_TEXT" & vbCrLf
              ' Gather data for the specific gameName row
              ' You'll need to adjust the row number (2 in this case) to the row where the gameName is located
              ' We're using a For loop here but you could also directly reference each cell if preferred
              Dim rowData As Range
              Set rowData = ws.Rows(2) ' Change this to the row number where gameName data is
              ' Add the data for the game name and fixed image URL
              csvContent = csvContent & """" & gameName & """," & _
              """https://plus.unsplash.com/premium_photo-1672280727393-ab6f0b26f527?auto=format&fit=crop&q=80& _
              w=1989&ixlib=rb-4.0.3&ixid=M3wxMjA3fDB8MHxwaG90by1wYWdlfHx8fGVufDB8fHx8fA%3D%3D""," & _
              """" & rowData.Cells(gameRow, "N").Value & """," & _
              """" & rowData.Cells(gameRow, "R").Value & """," & _
              """" & rowData.Cells(gameRow, "S").Value & """," & _
              """" & rowData.Cells(gameRow, "O").Value & """," & _
              """" & rowData.Cells(gameRow, "T").Value & """," & _
              """" & rowData.Cells(gameRow, "U").Value & """," & _
              """" & rowData.Cells(gameRow, "M").Value & """," & _
              """" & rowData.Cells(gameRow, "V").Value & """," & _
              """" & rowData.Cells(gameRow, "W").Value & """" & vbCrLf
              ' Add the "Items" row
              csvContent = csvContent & "Items" & vbCrLf
              ' Add the headers for the items section
              csvContent = csvContent & "id,USD,TOTAL_PRIZES,ODDS_WINNINGS,IMG,COLOR,TEXT,POSITION" & vbCrLf
              ' Reset item counter for each game
              itemCounter = 1
              For j = 2 To lastRow
                   If ws.Cells(j, 4).Value = gameName Then
                         ' The ID is a number, so it is converted to a string.
                         csvContent = csvContent & CStr(ws.Cells(j, "G").Value) & "," ' id (sr no)
                         ' Check if the USD cell contains an error or is empty.
                         If Not IsError(ws.Cells(j, "H").Value) And Not IsEmpty(ws.Cells(j, "H").Value) Then
                             csvContent = csvContent & """$" & CStr(ws.Cells(j, "H").Value) & """," ' USD with $ sign
                         Else
                             csvContent = csvContent & """," ' Empty or error value in USD field
                         End If
                         ' Convert numeric values to strings to avoid type mismatch errors.
                         csvContent = csvContent & CStr(ws.Cells(j, "L").Value) & "," ' TOTAL_PRIZES
                         csvContent = csvContent & """'1 in " & CStr(ws.Cells(j, "X").Value) & """," ' ODDS_WINNINGS
                         csvContent = csvContent &"""https://upload.wikimedia.org/wikipedia/commons/thumb/b/b6/ _
                         Image_created_with_a_mobile_phone.png/220px-Image_created_with_a_mobile_phone.png""," ' IMG
                         csvContent = csvContent & """" & CStr(ws.Cells(j, "I").Value) & """," ' COLOR
                         csvContent = csvContent & """item " & CStr(ws.Cells(j, "G").Value) & """," ' TEXT (item x)
                         ' Check if the POSITION cell contains an error or is empty.
                         If Not IsError(ws.Cells(j, "P").Value) And Not IsEmpty(ws.Cells(j, "P").Value) Then
                             csvContent = csvContent & CStr(ws.Cells(j, "P").Value) ' POSITION
                         Else
                             csvContent = csvContent & "" ' Empty or error value in POSITION field
                         End If
                         csvContent = csvContent & vbCrLf ' New line at the end of the row
                    End If
              Next j
              ' Create a valid filename based on the game name and current date-time
              gameName = Replace(gameName, " ", "_")
              gameName = Replace(gameName, "/", "_")
              gameName = Replace(gameName, "\", "_")
              gameName = Replace(gameName, ":", "_")
              myFile = csvFolderPath & "\" & sanitizedGameName & "-" & Format(Now, "ddd MMM dd yyyy HH_nn_ss") & _
              " GMT+0530 (India Standard Time).csv"
              ' Write the CSV content to a file
              fNum = FreeFile
              Open myFile For Output As fNum
              Print #fNum, csvContent
              Close fNum
          End If
    Next key
    ' Re-enable screen updating and alerts
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "CSV files generated successfully!"
End Sub