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