Вставьте и измените размер изображения с VBA на Mac - PullRequest
Новая
       51

Вставьте и измените размер изображения с VBA на Mac

0 голосов
/ 22 февраля 2019

Я пытаюсь запустить код VBA для автоматической вставки изображений с использованием определенной ссылки (имя .jpg и имя написано в Excel).Я использую Mac и получаю сообщение об ошибке:

Ошибка времени выполнения '1004 '

Если кто-то может помочь, я включил код I'м, используя ниже: 

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 Ответ

0 голосов
/ 22 февраля 2019

Обратите внимание, что…

  • … если вы определите Set PasteHere = Cells(x, 1), то PasteHere.Row будет всегда x, поэтому, если вы определите PasteRow = PasteHere.Row, тогда x и PasteRow всегда одинаковы, и вместо PasteRow вы всегда можете использовать x (или наоборот) и для этого не нужны две переменные.

  • … Вместо Cells(PasteRow, 1).Left вы можете напрямую использовать PasteHere.Left.

  • … вам следует избегать использования Select в Excel VBA и ссылаться на свой лист для всех ячеек /диапазоны.

  • … которые я не буду использовать Picture в качестве имени процедуры, поскольку это может вызвать путаницу с существующими свойствами. 

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

* Источник: https://www.rondebruin.nl/mac/mac008.htm

...