Добрый день!
пытаюсь собрать макрос вставки изображений в эксел и не могу добиться что бы:
1) изображения оставались в тушке файла
2) изображение пропорционально подгонялось под границы ячейи, и выравнивалось по центру
Макрос работает, но два условия одновременно не соблюдаются, выделено красным
помогите решить эту задачу
пытаюсь собрать макрос вставки изображений в эксел и не могу добиться что бы:
1) изображения оставались в тушке файла
2) изображение пропорционально подгонялось под границы ячейи, и выравнивалось по центру
Макрос работает, но два условия одновременно не соблюдаются, выделено красным
помогите решить эту задачу
| Код |
|---|
Sub GetImage1()
Dim img, img1 As Picture, T, L, W, h As Single
Dim CellX As Single
Dim GetOne As String
'p = ActiveWorkbook.Path
' ChDir p
GetOne = Application.GetOpenFilename("Image Files (*.jpg;*.bmp;*.gif;*.ico), *.jpg;*.bmp;*.gif;*.ico")
Application.ScreenUpdating = False
With ActiveCell
L = .MergeArea.Left
T = .MergeArea.Top
W = .MergeArea.Width
h = .MergeArea.Height
CellX = h / W
On Error Resume Next
ActiveWorkbook.ActiveSheet.Shapes.AddPicture GetOne, False, True, L, T, W, H - картинка в границы ячейки и остается в файле
'ActiveSheet.Pictures.Insert(GetOne).Select - картинка пропорционально подгоняется под границы ячейи, но не остается в файле при переносе на другой комп.
With Selection.ShapeRange
.LockAspectRatio = True
.Placement = xlMove
If .Height / .Width > CellX Then
.Height = h - 4
.Left = L + (W - .Width) / 2
.Top = T + 2
Else
.Width = W - 4
.Top = T + (h - .Height) / 2
.Left = L + 2
End If
L = .Left
T = .Top
h = .Height
W = .Width
.Width = .Width
End With
End With
Application.ScreenUpdating = True
End Sub
|
Изменено: - 04.01.2017 22:56:06
O Tempora, O Mores!!!
