-1

Here are the macros that I found on Extendoffice

Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub

I plan to add something that once clicked will insert an image and compress the image to reduce the file size at once. I need help writing a macro. Any assistance will be highly appreciated.

Pᴇʜ
  • 56,719
  • 10
  • 49
  • 73
Dhimas AFanji
  • 91
  • 9
  • Possible duplicate of [How to insert a picture into Excel at a specified cell position with VBA](https://stackoverflow.com/questions/12936646/how-to-insert-a-picture-into-excel-at-a-specified-cell-position-with-vba) – Niayesh Isky Mar 24 '19 at 05:04
  • What is your question? You didn't ask one. Please read [Why is “Can someone help me?” not an actual question?](https://meta.stackoverflow.com/a/284237/3219613). What is wrong with your code? – Pᴇʜ Mar 25 '19 at 07:16

1 Answers1

0

Same problem but for word, with embedded images in Outlook at original size when saved in Word via a slipstick.com macro.

With regards to compression, you could use SendKeys, there is a good blog on this at wellsr.com . In Word this is problematic as on opening Word by default the tick box is selected to apply to this image only. So sendkeys macro is likely to fail if you want to apply to one or all images in one go. As you can't control the tick on or off at any run time for the macro. The only solution is to loop image handling for example adding from a folder, so that each image is added to a temp file and compressed by send keys one at a time before being added to the active document final destination. I only just thought of this solution but have not coded it yet.

Sub ResizePicturesIF()

'Macro S

Dim oDoc As Document, oShape As InlineShape

Set oDoc = Application.ActiveDocument

For Each oShape In oDoc.InlineShapes

    If oShape.Width > 510 Then

        oShape.LockAspectRatio = True

            oShape.Width = 510

    End If     

    If oShape.Height > 660 Then

        oShape.LockAspectRatio = True

            oShape.Height = 660

    End If       

Next

Set oDoc = Nothing

End Sub

James Martin
  • 1
  • 2