Picture Resize Then Crop 1

[KristianDude]

Good morning,

Basic user here trying to make my life easier with a standard company form that I fill out every day and hoping to get a little help on this forum! I am trying to use VB to upload multiple pictures, set them to 7" wide, then crop the height to 4" if it is taller than 4" after the resize. The idea is that no matter what size the picture is, assuming it is larger than 4"x7", I shrink it to 7" wide (aspectratio locked), then crop the excess above and beyond from the top and bottom of the picture. If it were 5" tall, I'm trying to write out 5" - 4" = 1". Then divide by half and crop that amount from the top and bottom. So, the full line would be 5" - 4" / 2 = height to be cropped at top and bottom. I am having a heck of a time trying to get it to get it to crop the way I want!!!.. does anyone see my flaw???.. here is the entire code from that sub. Hopefully I explained it enough!? Thanks for anything you guys can do!.. also, if anything else looks sloppy I would love any feedback! :]

Sub InsertImage()
Dim doc As Word.Document
Dim bkmName As String
Dim SigFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set doc = ActiveDocument
Dim vrtSelectedItem As Variant
Dim theText() As String
Dim theText2 As String
Dim ILS As InlineShape
Dim strHeight

'default folder directory
fd.InitialFileName = "%userprofile%\documents"

With fd
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1
.FilterIndex = 1
If .Show = -1 Then

MsgBox "Please wait for pictures to load completely before proceeding with anything else"

For Each vrtSelectedItem In .SelectedItems

Set mg2 = ActiveDocument.Range
mg2.Collapse wdCollapseEnd

'alter picture
Set ILS = Selection.InlineShapes.AddPicture(FileName:= _
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True)

'add text
With Selection
.TypeText (Chr(10) & "Body Text" & Chr(10) & Chr(10))
.Collapse (wdCollapseEnd)
End With

'picture resize
With ILS
.LockAspectRatio = True
'height is 4" or 288 points
'Width is 7" or 503.99999999999 points
.Width = 503.99999999999

strHeight = ILS.Height - PointsToInches(4)
strHeight = strHeight / 2

.PictureFormat.CropTop = strHeight
.PictureFormat.CropBottom = strHeight

'end resize
End With

Next vrtSelectedItem
Else
End If
End With

Set fd = Nothing

'compress pictures
With Application.CommandBars.FindControl(ID:=6382)
SendKeys "%A%W{Enter}"
.Execute
End With

'Complete message
MsgBox "Picture import complete"

End Sub


Thank you!
Kristian

 

[KristianDude]

I think I might know what it is.. the compress code that I am using isn't quite doing what I want yet. If I try to do anything to the picture like sharpen it, it disappears.. well, it actually turns white. If I crop/compress it to 96 dpi and then sharpen it, it works just fine.. I think that maybe the image is too large pixel or something wise!.. I think the issue may lay in the pic file size.. not necessarily the image size being displayed??

 

[strongm]

Yes, the compresssion code you are using is a bit of a hack; we can probably do better. I'll have a quick think.

 

[strongm]

Ok, procedure now includes 'compression'

[blue]Public Sub StretchCropInline(myILS As InlineShape, Optional StretchWidth As Single = 7, Optional CropHeight As Single = 4, Optional RequireCompression As Boolean = True)
    Const wdPasteGIF = 13& [green]' Typically these Consts would be at module level, but I'm keeping this encapsulated within the procedure for sake of the example[/green]
    Const wdPastePNG = 14&
    Const wdPasteJPG = 15&

    Dim MaxWidth As Single
    Dim CurrentWidth As Single
    Dim CropMargin As Single
    Dim OldRatioType As MsoTriState
    
    [green]' reset ILS to fullsize image[/green]
    With myILS.PictureFormat
        .CropBottom = 0
        .CropTop = 0
        .CropLeft = 0
        .CropRight = 0
    End With
    
    MaxWidth = InchesToPoints(StretchWidth)
       
    With myILS
        OldRatioType = .LockAspectRatio
        .LockAspectRatio = msoTrue
        .ScaleWidth = 100 [green]' make sure picture actual size[/green]
        CurrentWidth = .Width
        .ScaleWidth = 100# * MaxWidth / CurrentWidth    [green]' Calc and set scale width as percentage[/green]
        CropMargin = (.Height - InchesToPoints(CropHeight)) / 2 * (CurrentWidth / MaxWidth) [green]' calc for margin as if applied to original picture, as it is scaled[/green]
        .PictureFormat.CropTop = CropMargin
        .PictureFormat.CropBottom = CropMargin
        .LockAspectRatio = OldRatioType
        
        If RequireCompression = True Then
            [green]' Warning the below has the side effect of resetting the InlineShapes iterator if it is being used[/green]
            .Select
            Selection.Cut
            Selection.PasteSpecial DataType:=wdPasteJPG, Placement:=wdInLine
            Selection.Collapse
        End If
    End With
End Sub[/blue]

 

[KristianDude]

First of all, I can't believe how much you are helping me out on this. THANK YOU!!!... secondly, yeah!.. this gets the compression down where it needs to be!!.. so it works for one picture but when I choose to select 2 or more pics it won't get past the first one. I'll try putting it in a separate sub and see if that does the trick!?

 

[KristianDude]

Actually, I think I see an easier way.. is there an added line I can put in at the end of the StretchCropInline sub to reset the focus/object to where it needs to be to keep running the code properly?

 

[SkipVought]

If you're resizing more than one pic, you must be performing this is a loop or in some other way such that you reference each inline shape in the set one at a time.

How are you accomplishing this?

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[strongm]

Note the following comment in the code:

[tt][green]' Warning the below has the side effect of resetting the InlineShapes iterator if it is being used[/green][tt]

To clarify: it'll reset the iterator/enumerator (For Each) of a collection if a collection is being used to access the pictures (because it deletes a shape from the collection and then inserts a new, compressed one, albeit in the same position)

And it certainly sounds from your symptoms as if that is what is happening. Use a more traditional loop instead:

e.g. For lp = 1 To ActiveDocument.InlineShapes.Count

Without a view of your code, though, I can't suggest much more. It works fine here.

 

[KristianDude]

I have the code posted above on 3/21/16 under the sub name InsertImage... so to my eye it looks like I need to get the focus back to the inlineshapes after I call on StretchCropInline?.. so would I put this (below) in again just as a placeholder for the next count?.. it seems redundant to me?

Set ILS = Selection.InlineShapes.AddPicture(FileName:= _
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True)

 

[KristianDude]

Okay, I got it!!.. I removed the old hacked way of calling for compression with the sendkeys.. I thought that was the end of it all, but if you guys can bear with me for one more I'll be done I promise!!.. so when I select for more than one picture, usually they will insert in the order that I select them. For some reason it is reversing the order of the pictures when it is all said and done.. it appears that the copy/paste feature is pasting each image in front of (or before) the last image pasted into place?

 

[strongm]

Examine this line in my procedure, and see if you can figure out how to change it to get the result you want:

Selection.Collapse

 

[KristianDude]

Ok, I've tried Selection.Collapse (wdCollapseEnd), Start, move, movedown, moveright.. now I am noodling with placement in other areas.. will get back to you thanks!

 

[strongm]

Ah. Hmm. Ok ...

Couple of things

Firstly, you don't really have much control over the order in which multiple file names are returned from the file dialog as you might think you do. File dialog returns files based on the sort order of the column you sort the dialog on, with the exception that the last file physically selected is moved to first place.

Secondly, your own code inverts the order due to your insertion code:

[tt]Set ILS = Selection.InlineShapes.AddPicture(FileName:= _
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True)[/tt]

Modify it to

[tt]Set ILS = Selection.InlineShapes.AddPicture(FileName:= _
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, Range:=mg2)[/tt]

 

[KristianDude]

Well... I've learned a lot through this whole thing. It would have taken weeks for me to figure out that little snippet strongm. Thank you!!!!.. what you have given to me corrects the order of the pictures!.. the order of the little line of text I was inserting has now reversed.. holy moly... it places text before (on top) of the picture vs after (below). I am moving that line of code all over the place and it still keeps ending up in the same spot (before the pic)!!.. is there a simple setting that I am missing again!? I am assuming that the way I had it working before was probably a messy way of doing it, so now that things seem to be in perfect working order my little snippet of text that I had needs re-working! I will keep trying on my end and report back if I get it!!

 

[strongm]

Oh, I know how to fix that - but not for a couple of hours, I'm afraid. See if you can figure out what may be happening in the meantime. It is related to the insertion point ...

 

[KristianDude]

Ok looking for it!

 

[strongm]

Clue. My routine cuts the picture out of the current Selection object, and inserts it after it ...

 

[strongm]

Ok ... put [tt]Selection.MoveRight[/tt] just before [tt]Selection.Collapse[/tt] in my StretchCropInline procedure. That's the basic fix.

 

[KristianDude]

Well.. I can't believe it was that simple!!!.. I've been working on it off and on since this morning and BAM.. your suggestion works great!!

 

[KristianDude]

Sooooo..... this is back from the dead... I normally put labels over the pictures that I am inserting (as in this thread), but am having issues trying to figure out how to get a label to attach to a picture as it cycles through the above procedure. I know where to put the procedure call in the code (I think), but I can't for the life of me figure out how to find the bottom left of a picture and place a label (code below) on top of it. Anybody ever deal with this or is this crazy?? Thanks for anything!

Private Sub cmdLabel_Click()
    Dim shp As Shape
     
     Set shp = ActiveDocument.Shapes.AddShape(Type:=msoShapeRectangle, _
        Left:=24, Top:=65.6, Width:=100, Height:=22)

     
     'FORMAT SHAPE
    'Shape Name
        shp.Name = "My Header"
    
    'No Shape Border
        shp.Line.Visible = msoFalse
    
    'Shape Fill Color
        shp.Fill.ForeColor.RGB = RGB(129, 133, 114)
    
    'Shape Text Color
        'shp.TextFrame.TextRange.Font.ColorIndex = RGB(255, 255, 255)
    
    'Semitransparent background
        shp.Fill.Transparency = 0.15
    
    'Center Align Text
        shp.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphCenter
    
    'Vertically Align Text to Middle
        shp.TextFrame.VerticalAnchor = msoAnchorMiddle
    
    'Adjust Font Size
        shp.TextFrame.TextRange.Font.Size = 11
    
    'Adjust Font Style
        shp.TextFrame.TextRange.Font.Name = "Calibri"
    
    'Text inside Shape
        shp.TextFrame.TextRange.Text = "enter your text here"
    
    'Size box with text
    shp.TextFrame.WordWrap = msoFalse
    shp.TextFrame.AutoSize = msoAutoSizeShapeToFitText

End Sub

 

[SkipVought]

Your added shape has a Left and Top position and a Width and Height size.

From those dimensions, you could put a Textbox positioned where you need and of an appropriate size.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]