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

 

[Andrzejek]

First, KristianDude, welcome to Tek-Tips
Second, when present your code, please use TGML tags (above the box where you type your posts or replies). it makes a lot easier to read it. Use Preview to see your post before Submitting.

Third,
Would your code work OK if you would hard-code the values to resize the picture?

Have fun.

---- Andy

A bus station is where a bus stops. A train station is where a train stops. On my desk, I have a work station.

 

[SkipVought]

You want inches to points not points to inches.

Your code is converting 4 points to inches???

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

 

[KristianDude]

Skip.. thank you for catching that!!.. I changed that but still some other issue??.. it is still too tall

Andy.. Ok thanks for the heads up and thanks for the welcome!.. yes, hard numbers would work, but I do need to find the overage of the height above 4".. I tried a scale function but didn't seem to code it properly as it cut the pictures in half. The reason I need to do this is because I import from several devices that have different settings that I can't ever seem to get to be identical. Some pictures are 1024 x 768 format and others can be 800 x 600 format. The idea is that I am resizing all of these down to a 4"x7" picture in my word document. So, the way I am trying to do it is by setting the 7" with the inlinepictures.addpicture function and cropping it down. IF there is a simpler way to do this, I am all ears!! My original idea was basically...

'picture resize
With ILS
.LockAspectRatio = True
.Width = 503.99999999999

strHeight = ILS.ScaleHeight - InchesToPoints(4)
strHeight = strHeight / 2

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

'end resize
End With


Thank you!
Kristian

 

[Andrzejek]

I was suggesting hard-coded values not to leave them there permanently, but to insure the logic is right. So if you know how much to crop the picture from top and bottom, use hard numbers first. If it works, then you can figure out the calculations/math needed to get this value.

So if the [blue] value of 0.5 would work for a particular picture, then you would figure out the logic to assign 0.5 to your variable [tt]strHeight[/tt] (which is declared as Variant, but named as String...?)

[green]
'picture resize[/green]
With ILS
    .LockAspectRatio = True
    .Width = 503.99999999999

    strHeight = ILS.ScaleHeight - InchesToPoints(4)
    strHeight = strHeight / 2

    .PictureFormat.CropTop = [blue]0.5[/blue]
    .PictureFormat.CropBottom = [blue]0.5[/blue]
[green]
    'end resize[/green]
End With

Have fun.

---- Andy

A bus station is where a bus stops. A train station is where a train stops. On my desk, I have a work station.

 

[KristianDude]

Oh I see what you are saying.. just tried that out.. so an example picture that I am using, when scaling the width to 7" has a height of 5.25". I plugged in the below and the picture is still 5.06" tall??.. adding them together, if I remove 1.25" from 5.25" I should have 4".. not sure what I am doing wrong here?!... does it look like I might be cropping the image before I size it down maybe??

.PictureFormat.CropTop = InchesToPoints(0.625)
.PictureFormat.CropBottom = InchesToPoints(0.625)




Thank you!
Kristian

 

[KristianDude]

I just figured out that I am using the scaleheight function imporoperly in the last post. It's only for scaling a picture (shrink/stretch) which is what I am trying to avoid by trying to go the cropping route. So, I guess the question I have it... how do I find the height of the picture once it has been sized down to a 7" width? With that I can get to where I need to go!



Thanks!
Kristian

 

[KristianDude]

Okay, I am almost there.. any idea how to crop an actual value? My crop value is working great with the new code I added below, but it only works on the original size of the picture!??.. now that I know the difference in height of the resized picture vs. the 7" that I want to achieve, what is a way to crop it to the numbers that I come up with? Thanks for anything you have... here is the newest snippet that actually achieves getting the values that I need...

Dim Pic As IPictureDisp

'picture dimensions
imgwidth = Round(ILS.Width)
imgheight = Round(ILS.Height)

'set value for cropping
strHeight = imgheight - 288
strHeight = strHeight / 2


MsgBox "imgheight " & imgheight & "strHeight = " & strHeight

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

'end resize
End With



Thanks,
Kristian

 

[KristianDude]

If it helps anything, the MsgBox states that the imgHeight is 378 (5.25") and the ilsHeight is 45 at 72 points per inch I would assume. These are exactly what I need. When I enter the values into the .pictureformat.croptop and bottom functions, I get a picture height of 5.06. Any idea what the crop function is doing to achieve that??

 

[strongm]

[blue]Public Sub StretchCropInline(myILS As InlineShape, Optional StretchWidth As Single = 7, Optional CropHeight As Single = 4)
    Dim MaxWidth As Single
    Dim CurrentWidth As Single
    Dim CropMargin As Single
  
    MaxWidth = InchesToPoints(StretchWidth)
    myILS.ScaleWidth = 100 'make sure picture actual size
    CurrentWidth = myILS.Width
     
    myILS.ScaleWidth = 100 * MaxWidth / CurrentWidth ' Calc and set scale width as percentage

    CropMargin = (myILS.Height - InchesToPoints(4)) / 2 * (CurrentWidth / MaxWidth) 'calc for margin as if applied to original picture, as it is scaled
    myILS.PictureFormat.CropTop = CropMargin
    myILS.PictureFormat.CropBottom = CropMargin
End Sub[/blue]

 

[KristianDude]

strongm.. thank you very much!!.. I posted the public sub and am calling it from the insertimage sub and it is giving me the "argument not optional" pop up. This is a bit above my head, but I can troubleshoot however you say!?.. here is the insertimage code with the call for the StretchCropInline sub...

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
 'add resize
 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
    StretchCropInline
    
    'end resize
    

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

 

[strongm]

[blue][tt]StretchCropInline ILS[/tt][/blue]

 

[KristianDude]

Holy Crayopa that was fast!!.. I just tried it and the process completes, but no cropping!.. also no sizing.. size is 5.63 x 7.5

 

[KristianDude]

Sorry, I made a mistake!!!.. it works, but the height is 3.88!.. thank you!!.. but is there a way to get it to 4"?

 

[strongm]

Should be 4". What version of Word?

 

[strongm]

Actualy, I think I know what the problem is, and it should have been fixed by a minor edit I provided to my code, but which I may have inserted after you copied it. The issue is caused when an image wider than the current margins is inserted, which Word then scales for you to make it fit the margins. But the code as originally posted works on the assumption that the image is 100% of original size; if it isn't, we get a scaling error. The fix I introduced:

myILS.ScaleWidth = 100 'make sure picture actual size

should address that.

Here's a slightly more comprehensive modification to the code that should also deal with the scenario where you pass an image that has been cropped (unlikely if you are just loading the image from disk, however). I've also slightly optimised the code

[blue]Public Sub StretchCropInline(myILS As InlineShape, Optional StretchWidth As Single = 7, Optional CropHeight As Single = 4)
    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 'make sure picture actual size
        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
    End With
End Sub[/blue]

 

[KristianDude]

Wow yeah!! That did it!!!! Thank you so much!!!!!!!

 

[KristianDude]

Ok, one last one.. can anyone see what may be causing the pictures to be deleted/disappear after the code (InsertImage) posted above runs completely? If I ctrl+z 2 times after everything completes (step it back 2 commands) the pictures are there resized and all. I can't figure out what is causing them to disappear at the very end!?!? I tried shifting the focus to the documents after the process, but that doesn't do the trick?

 

[Andrzejek]

Did you try to Step Through Code in VBA and see where in the code your pictures is deleted/disappear ?

Have fun.

---- Andy

A bus station is where a bus stops. A train station is where a train stops. On my desk, I have a work station.

 

[KristianDude]

Yes. For some reason, it says that I can't insert a break and I am forced to let it autorun the entire thing anyway. What I have been doing is adding the " ' " symbol to the front of lines or processes and still can't track it!