Как сохранить изображение самостоятельно в модуле VBA
У меня есть модуль ниже, чтобы вставить изображение в выбранную объединенную ячейку и автоматически изменить размер изображения в соответствии с шириной или высотой этой ячейки. Но у меня возникла проблема при отправке этого отчета моему клиенту: они не видят изображения, поскольку мой код вставил их в качестве пути к местоположению. Единственное решение, которое у меня есть сейчас, — это «сохранить в формате pdf», тогда клиенты смогут увидеть отчет.
Есть ли способ сохранить файл Excel с изображениями, чтобы мои клиенты могли их просматривать при загрузке?
Sub INSERT_PIC()
Dim MyMergeCell As Range
Dim MyFile As String
Dim MyPath As String
'---------------------------------------------------------------------------
'- SELECTED CELL
Set MyMergeCell = ActiveCell
'---------------------------------------------------------------------------
'- OPEN THE FILE WITH GetOpenFilename()
MyFile = Application.GetOpenFilename("Picture Files (*.bmp;*.jpg;*.tif;*.gif), *.bmp;*.jpg;*.tif;*.gif", , " GET PICTURE", , msoTrue)
If MyFile = "False" Then Exit Sub
'----------------------------------------------------------------------------
'- INSERT THE FILE INTO THE WORKSHEET
ActiveSheet.Pictures.Insert(MyFile).Select
'----------------------------------------------------------------------------
'- RESIZE PICTURE TO MERGE CELL. REFORMAT
With MyMergeCell
Dim r As Range, sel As Shape
Set sel = ActiveSheet.Shapes(Selection.Name)
sel.LockAspectRatio = msoTrue
Set r = Range(sel.TopLeftCell.MergeArea.Address)
Select Case (r.Width / r.Height) / (sel.Width / sel.Height)
Case Is > 1
sel.Height = r.Height
Case Else
sel.Width = r.Width
End Select
sel.Top = r.Top: sel.Left = r.Left
End With
End Sub
Ответы 1
Глядя на некоторые следы в Интернете (например, на вопрос SO, на который Тим Уильямс ссылался в комментариях), кажется, что от версии Excel зависит, связаны ли изображения или встраиваются только при использовании Pictures.Insert.
Вместо этого используйте Shapes.AddPicture, там вы можете определить, хотите ли вы встроить изображение или только связать их. Еще одно отличие от метода Insert заключается в том, что вам уже нужно указать местоположение, а AddPicture является функцией, поэтому вам не нужно возиться с Select.
Если вы посмотрите на ответ https://stackoverflow.com/a/58500935/7599798, вы приблизитесь к тому, что вам нужно. Я объединил код из этого ответа с вашим кодом, чтобы он работал с объединенными ячейками:
Sub INSERT_PIC()
Dim r As Range
Set r = ActiveCell.MergeArea
Dim MyFile As Variant
MyFile = Application.GetOpenFilename("Picture Files (*.bmp;*.jpg;*.tif;*.gif), *.bmp;*.jpg;*.tif;*.gif", , " GET PICTURE", , msoTrue)
If MyFile = False Then Exit Sub
Dim sh As Shape
Set sh = ActiveSheet.Shapes.AddPicture(MyFile, False, True, r.Left, r.Top, -1, -1)
sh.LockAspectRatio = True
If (r.Width / r.Height) / (sh.Width / sh.Height) > 1 Then
sh.Height = r.Height
Else
sh.Width = r.Width
End If
End Sub
Привет, Томас, я не могу выразить свою благодарность :D Ты сделал это так просто по сравнению с моим исходным кодом. Я понимаю ваш код и очень рад, что могу отказаться от Picture.Insert и .Select сейчас.