Consulting

Results 1 to 7 of 7

Thread: Convert VBA Code Designed for Windows To Run On A Mac

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1

    Convert VBA Code Designed for Windows To Run On A Mac

    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.

  2. #2
    Moderator VBAX Wizard Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    5,110
    Location
    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
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  3. #3
    Moderator VBAX Wizard Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    5,110
    Location
    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
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  4. #4
    Moderator VBAX Wizard Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    5,110
    Location
    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.
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  5. #5
    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.

  6. #6
    Moderator VBAX Wizard Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    5,110
    Location
    Not high enough post count I'm assuming. Admin have their rules.
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  7. #7
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •