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]

Thanks Skip.. I will play with this a bit more today. Hopefully with some progress.. I am guessing it is something like picture.select, moveleft, insert label. I tried this a bit yesterday with no luck. Can you give a pointer on how to get placement of the picture? This is what I what I was researching yesterday and just couldn't seem to crack it

 

[SkipVought]

A graphic element has 4 dimensions:

Top-pixels from the top edge of the document
Left-pixels form the left edge of the document

Those dimensions place the graphic element.

To place an object below your pic, makr the Top of the object equal to the Top of the pic plus the Height of the pic.


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

 

[KristianDude]

Any idea on how to reference the top/left of the pic? That is the issue that I am having. I assume that in the line...

Set shp = ActiveDocument.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=24, Top:=65.6, Width:=100, Height:=22)

... I can have left and top reference the picture. The issue that I seem to be having is getting a handle on referencing the top and left of the picture itself. Once pasted should I be able to do something like..

Dim picLeft
Dim picTop

picLeft = ?
picTop = ?

Set shp = ActiveDocument.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=picLeft, Top:=picTop, Width:=100, Height:=22)

So, the question in my brain at the moment is, what should picLeft = and what should picTop =?.. this is the mystery that has me stumped

 

[SkipVought]

Once pasted..." Pasted? Where are your you pasting?

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

 

[KristianDude]

It is from the posts over the last few weeks.. here is what I am using this with... courtesy of StrongM. I highlighted the spot that I reference calling this sub. :]

Sub InsertImage()
 Dim doc As Word.Document
 Dim fd As FileDialog
 Set fd = Application.FileDialog(msoFileDialogFilePicker)
 Set doc = ActiveDocument
 Dim vrtSelectedItem As Variant
 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, Range:=mg2)
                    
    'picture resize
    StretchCropInline ILS
    
Next vrtSelectedItem
 Else
 End If
 End With

Set fd = Nothing

'Complete message
MsgBox "Picture import complete"

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

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

 

[SkipVought]

So it's pasted. Now you reference this object and assign the Top & Left properties.

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

 

[KristianDude]

Right. Just having the issue of how to grab the reference from the pasted pic

 

[strongm]

[blue][green]' Assumes that just before current insertion point is an inline picture shape[/green]
Public Sub InsertTextbox(strText As String)
    Selection.MoveLeft , , True [green]'Select inline picture just before insertion point[/green]
    With ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, Selection.Information(wdHorizontalPositionRelativeToPage), Selection.Information(wdVerticalPositionRelativeToPage) + Selection.InlineShapes(1).Height, 10, 14)
        .Line.Visible = msoFalse
        .TextFrame.TextRange.Font.Size = 11
        .TextFrame.TextRange.Font.Name = "Calibri"
        .TextFrame.TextRange.Text = strText
        .TextFrame.WordWrap = msoFalse
        .TextFrame.AutoSize = msoAutoSizeShapeToFitText
        
        .Fill.ForeColor.RGB = RGB(129, 133, 114)
        .Fill.Transparency = 0.15
            
        .TextFrame.MarginBottom = 0 [green]'adjust text margins[/green]
        .TextFrame.MarginLeft = 0
        .TextFrame.MarginRight = 0
        .TextFrame.MarginTop = 0
        .Line.Visible = msoFalse [green]'don't show the border[/green]
        .Top = .Top - .Height
    End With
    
    Selection.MoveRight
    Selection.Collapse [green]'Move selection point to just after current selection (i.e. where we started)[/green]
End Sub[/blue]

And call it by adding something like
[tt]InsertTextbox CStr(vrtSelectedItem)[/tt]

after [tt]StretchCropInline ILS[/tt] in your InsertImage sub

 

[KristianDude]

Oh man that works so good. I put it at the end of the StretchCropInline procedure (just before all the insert text line) as it threw up an error being in the InsertImage procedure after the StretchCropInline call? It looks like it works properly to me!?

 

[KristianDude]

Also, here is a weird one that has been happening after this procedure runs lately.. the cursor changes to the move cursor, the kind shaped like a plus sign with arrows at the ends of all 4 sides. When it does this I can't click on the buttons that I have on the page. Is this a focus issue??

 

[strongm]

There are things you need to figure out yourself ...

 

[KristianDude]

Thanks for all the major help with this project… You have help it advance tremendously.