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_LOSIN G, _
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