VBA Code - Picture (HD Resolution)

[Spaztic]

Hi! To insert pictures, I use the .Shapes.AddPicture so that the pictures aren't being treated as a hyperlink.

The issue I'm having is that when my code runs and it inserts a picture, sometimes the picture is grainy or if I adjust the picture, it is grainy. I noticed that 'use default resolution' is checked in the 'Compress Pictures' section.

It seems to be much better if I:

• Select the picture
• Picture Format
• Compress Pictures
• Select HD (330 ppi): good quality for high-definition (HD) displays

Is there code I can add when inserting the picture where the HD setting can be automatically applied to the picture?

    Dim fNameAndPath As Variant
    Dim rng As Range
    Dim img As Shape
 
    fNameAndPath = Application.GetOpenFilename( _
        FileFilter:="Image Files (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        Title:="Select an Image", _
        ButtonText:="Select")
      
    If fNameAndPath = False Then Exit Sub
 
    Set rng = ActiveCell
 
    Set img = ActiveSheet.Shapes.AddPicture(fileName:=fNameAndPath, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)
    With img
        If .Width > .Height Then
            .Width = rng.Width * 0.7
        Else
            .Height = rng.Height * 0.7
        End If
        .Left = rng.Left + (rng.Width - .Width) / 2
        .Top = rng.Top + (rng.Height - .Height) / 2
       .Placement = 1
       .PrintObject = True
    End With

 

[NdNoviceHlp]

Hi Spaztic. No guarantees but you can trial this code. Adjust the sheet name to suit. HTH. Dave

Sub test()
Sheets("Sheet1").Shapes.SelectAll
SendKeys "%e", True
SendKeys "~", True
SendKeys "{ENTER}"
Application.CommandBars.ExecuteMso "PicturesCompress"
End Sub

 

[Spaztic]

This didn't work. What it did was change all the pictures to 'Email (96 ppi)' and I'm looking to change them to 'HD (330 ppi)'

 

[NdNoviceHlp]

Hi again Spaztic. I did some more testing with the code and it seems like it compresses pictures in the first available format in the "Compress Pictures" dialog box. When you select the pics, is the HD (330ppi) compression available? The pics I trialed had different compression formats available. It did compress the pics in HD (330ppi) when it was available and it compressed others with the first available format available (eg. Print (220ppi)). I "borrowed" most of the code and adjusted it somewhat so I'm not real sure what to change if it's not working for you. Dave

 

[NdNoviceHlp]

Found another bit of code which seems to so the same thing. Dave

VBA.SendKeys "%W{ENTER}", True
Application.CommandBars.ExecuteMso ("PicturesCompress")

 

[Spaztic]

Thanks,
What I found is that Excel is compressing the images automatically. When I go to File, More, Options, Advanced, Image Size and Quality...I see that it is compressing the images as they come in. When I check 'Do not compress images in file'... that is what I'm wanting when inserting pictures.

The issue is, this file will be used by many users and I don't want them to have to go and do this every time. I was hoping that I could 'un-compress' or block the original image from compressing through vba code.

 

[NdNoviceHlp]

Interesting... I didn't know that was an option. If you select the "Do not compress images in file" option doesn't that stay with the file? I seem to have the same set up with my test file and when the pics are inserted they are at the default resolution and then after running the code the compression has changed. You could also adjust the default resolution to the 330 ppi so there would be no picture compression. That's all the suggestions I have. Good luck. Dave