Insert and resize a picture with VBA on Mac

问题

I'm trying to run a VBA Code in order to insert images automatically using a particular reference (name of .jpg and name written on Excel). I'm using a Mac and keep getting the error:

Run-time error'1004'

If anyone can help, I've included the code I'm using below:

Sub Picture()      
    Dim pictname As String
    Dim pastehere As Range
    Dim pasterow As Long
    Dim x As Long
    Dim lastrow As Long

    lastrow = Worksheets("sheet1").Range("B1").CurrentRegion.Rows.Count
    x = 2
    For x = 2 To lastrow
        Set pastehere = Cells(x, 1)
        pasterow = pastehere.Row
        Cells(pasterow, 1).Select 

        pictname = Cells(x, 2) 'This is the picture name
        ActiveSheet.Pictures.Insert("/Users/name/Desktop/macro" & pictname & ".JPG").Select 

        With Selection
            .Left = Cells(pasterow, 1).Left
            .Top = Cells(pasterow, 1).Top
            .ShapeRange.LockAspectRatio = msoFalse

            .ShapeRange.Height = 80#
            .ShapeRange.Width = 80#
            .ShapeRange.Rotation = 0#
        End With
    Next
End Sub

回答1:

Note that …

• … if you define Set PasteHere = Cells(x, 1) then PasteHere.Row is always x so if you define PasteRow = PasteHere.Row then x and PasteRow are always the same and instead of PasteRow you can always use x (or the other way round) and don't need two variables for that.

• … instead of Cells(PasteRow, 1).Left you can directly use PasteHere.Left.

• … you should avoid using Select in Excel VBA and reference your worksheet for all cells/ranges.

• … that I woud not use Picture as procedure name as this could cause confusings with existing properties.

---

Public Sub InsertPictures()      
    Dim PictName As String
    Dim PictFullPath As String
    Dim PasteHere As Range
    Dim PasteRow As Long
    Dim LastRow As Long

    Dim ws As Worksheet 'define worksheet and use it for all cells!
    Set ws = ThisWorkbook.Worksheets("sheet1")

    LastRow = ws.Range("B1").CurrentRegion.Rows.Count

    For PasteRow = 2 To LastRow 
        Set PasteHere = ws.Cells(PasteRow, 1)

        PictName = ws.Cells(PasteRow, 2).Value 'This is the picture name
        PictFullPath = "/Users/name/Desktop/macro/" & PictName & ".JPG" 'make sure your path ends with a /

        'test if picture exists before using it
        If FileOrFolderExistsOnMac(PictFullPath) Then
            With PasteHere.Pictures.Insert(PictFullPath)
                .Left = PasteHere .Left
                .Top = PasteHere .Top
                .ShapeRange.LockAspectRatio = msoFalse

                .ShapeRange.Height = 80#
                .ShapeRange.Width = 80#
                .ShapeRange.Rotation = 0#
            End With
        Else
            MsgBox "File '" & PictFullPath & "' was not found."
        End If
    Next PasteRow 
End Sub

Function to test if file or folder exists:

Function FileOrFolderExistsOnMac(FileOrFolderstr As String) As Boolean
'Ron de Bruin : 26-June-2015
'Function to test whether a file or folder exist on a Mac in office 2011 and up
'Uses AppleScript to avoid the problem with long names in Office 2011,
'limit is max 32 characters including the extension in 2011.
    Dim ScriptToCheckFileFolder As String
    Dim TestStr As String

    If Val(Application.Version) < 15 Then
        ScriptToCheckFileFolder = "tell application " & Chr(34) & "System Events" & Chr(34) & _
         "to return exists disk item (" & Chr(34) & FileOrFolderstr & Chr(34) & " as string)"
        FileOrFolderExistsOnMac = MacScript(ScriptToCheckFileFolder)
    Else
        On Error Resume Next
        TestStr = Dir(FileOrFolderstr, vbDirectory)
        On Error GoTo 0
        If Not TestStr = vbNullString Then FileOrFolderExistsOnMac = True
    End If
End Function

* Source: https://www.rondebruin.nl/mac/mac008.htm

来源：https://stackoverflow.com/questions/54824789/insert-and-resize-a-picture-with-vba-on-mac