Excel VBA - Shapes.AddPicture vs Pictures.Insert в электронную таблицу с подключенного диска

Question

Я использовал макрос Excel VBA для добавления изображений в списки электронных таблиц из папки на нашем офисном сервере.Список экспортируется из моей базы данных с указанием папки и имени изображения в столбце A (например, 038/19761809.jpg).Теперь мне нужно отправить эти документы лицам за пределами моего офиса без доступа к нашему серверу, поэтому я пытаюсь переключиться с использования ActiveSheet.Pictures.Insert на использование более правильного ActiveSheet.Shapes.AddPicture.Цель состоит в том, чтобы внедрить файлы изображений в документ, а не просто связать их с файлами на нашем офисном сервере.

Этот код (используя Pictures.Insert) вставляет изображения в виде ссылок.Когда я отправляю электронную таблицу электронной почте сторонним пользователям, связанные изображения «ломаются», поскольку компьютер получателя не может их найти (поскольку их компьютер отсутствует в нашей локальной сети).

Sub InsertPictures()
 Dim MyRange As String
 Dim picname As String
 Dim mySelectRange As String
 Dim rcell As Range
 Dim IntInstr As Integer
 Dim Mypath As String

 Mypath = "S:\pp4\images\"
 MyRange = "A2:A275"

 Range(MyRange).Select
 For Each rcell In Selection.Cells
    If Len(rcell.Value) > 0 Then
        picname = Mypath & rcell.Value
        mySelectRange = Replace(MyRange, "B", "A")
        IntInstr = InStr(mySelectRange, ":")
        mySelectRange = Left(mySelectRange, IntInstr - 1)
        do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
     End If
Next
Application.ScreenUpdating = True
End Sub

Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
    Dim rcell As Range
    Range(MyRange).Select
    On Error GoTo ErrNoPhoto

    ActiveSheet.Pictures.Insert(picname).Select
    On Error GoTo 0

    With Selection
     .Left = myleft + 4
     .Top = mytop + 4
     .ShapeRange.LockAspectRatio = msoTrue
     .ShapeRange.Height = 115#
     .ShapeRange.Rotation = 0#
    End With
Exit Sub
ErrNoPhoto:
 MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub

Я изменил свой код наиспользуйте форматирование для Shapes.AddPicture.Вот новый код:

Sub InsertPictures()
 Dim MyRange As String
 Dim picname As String
 Dim mySelectRange As String
 Dim rcell As Range
 Dim IntInstr As Integer
 Dim Mypath As String

 Mypath = "S:\pp4\images\"
 MyRange = "A2:A275"

 Range(MyRange).Select
 For Each rcell In Selection.Cells
    If Len(rcell.Value) > 0 Then
        picname = Mypath & rcell.Value
        mySelectRange = Replace(MyRange, "B", "A")
        IntInstr = InStr(mySelectRange, ":")
        mySelectRange = Left(mySelectRange, IntInstr - 1)
        do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
     End If
Next
Application.ScreenUpdating = True
End Sub

Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
    Dim rcell As Range
    Range(MyRange).Select
    On Error GoTo ErrNoPhoto

    ActiveSheet.Shapes.AddPicture(Filename:=picname, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=myleft + 4, Top:=mytop + 4, LockAspectRatio:=msoTrue, Height:=115#, Rotation:=0#).Select
    On Error GoTo 0
Exit Sub
ErrNoPhoto:
 MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub

Когда я пытаюсь запустить новый макрос, Excel просто выдает мое сообщение об ошибке «Не удается найти фотографию».Можете ли вы помочь мне найти то, что я сделал не так?Спасибо за любую помощь!

Answer 1

У вас есть 2 дополнительных аргумента в Shapes.AddPicture (LockAspectRatio, Rotation) и пропущенный (Width).

Подробнее о Shapes.AddPicture и вашем исправленном коде ниже:

Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)

    Dim sht As Worksheet: Set sht = ActiveSheet
    Dim rcell As Range
    Range(MyRange).Select
    On Error GoTo ErrNoPhoto

    With sht.Shapes
        .AddPicture _
            Filename:=picname, _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=myleft + 4, _
            Top:=mytop + 4, _
            Width:=-1, _
            Height:=115

    End With
    On Error GoTo 0
Exit Sub
ErrNoPhoto:
    Debug.Print "Unable to Find Photo" 'Shows message box if picture not found
End Sub

PS: я рекомендую вам прочитать о том, как избегать использования .Select во всем ...