Several macros for resizing photos to a specific size

Hi there,

I have struggled for hours trying to figure this out, but alas I need to ask. I am trying to create three different macros, for three specific photo sizes (Heights of 6.55, 9.86, and 12.5 with aspect ratio maintained).  Essentially I want to be able to click each of these three options when needed.  I think I figured it out here:, but then when I create the next macro my first one is gone for whatever reason.  Any help would be appreciated.

Sub sizeone()
Dim targetHeight As Integer
Dim oShp As Shape
Dim oILShp As InlineShape
targetHeight = 6.55
For Each oShp In Selection.ShapeRange
  With oShp
    .Width = AspectHt(.Height, .Width, CentimetersToPoints(9))
    .Height = CentimetersToPoints(6.55)
  End With
Next
For Each oILShp In Selection.InlineShapes
  With oILShp
    .Width = AspectHt(.Height, .Width, CentimetersToPoints(9))
    .Height = CentimetersToPoints(6.55)
  End With
Next
End Sub

Private Function AspectHt(ByVal origWd As Long, ByVal origHt As Long, ByVal newWd As Long) As Long
If origWd <> 0 Then
  AspectHt = (CSng(origHt) / CSng(origWd)) * newWd
Else
  AspectHt = 0
End If
End Function

 

Question Info


Last updated March 7, 2019 Views 19 Applies to:
Answer
Answer

I would take a different approach to Diane. I would use a single macro and use modifier keys to vary the size. This would allow you to have a single button to run the macro and you can hold the Shift or Ctrl key to get the other sizes. The following code needs to reside at the top of a module. 

Option Explicit

#If VBA7 Then

  Declare PtrSafe Function GetKeyState Lib "USER32" (ByVal vKey As Long) As Integer

#Else

  Declare Function GetKeyState Lib "USER32" (ByVal vKey As Long) As Integer

#End If

Global Const SHIFT_KEY = 16

Global Const CTRL_KEY = 17

Global Const ALT_KEY = 18

Sub ResizeAll()

  Dim tgtHeightCM As Double, oShp As Shape, oILShp As InlineShape

  

  If GetKeyState(SHIFT_KEY) < 0 Then

    tgtHeightCM = 9.86    'If user holds shift key, use size 2

  ElseIf GetKeyState(CTRL_KEY) < 0 Then

    tgtHeightCM = 12.5     'If user holds ctrl key, use size 3

  Else

    tgtHeightCM = 6.55    'default size

  End If

  

  For Each oShp In Selection.ShapeRange

    With oShp

      .LockAspectRatio = msoTrue

      .Height = CentimetersToPoints(tgtHeightCM)

    End With

  Next

  For Each oILShp In Selection.InlineShapes

    With oILShp

      .LockAspectRatio = msoTrue

      .Height = CentimetersToPoints(tgtHeightCM)

    End With

  Next

End Sub

Andrew Lockton
Melbourne Australia

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

Answer
Answer
Hi James,
>> when I create the next macro my first one is gone for whatever reason
The first macro disappears when you add the second? Are you using different names for the macros?

I would do it something like this - buttons on the ribbon for small, medium, and large.

Dim picSize As Variant
Sub Large()
picSize = 12.5
sizeone
End Sub

Sub Medium()
picSize = 9.86
sizeone
End Sub

Sub Small()
picSize = 6.55
sizeone
End Sub

Private Sub sizeone()
Dim targetHeight As Integer
Dim oShp As Shape
Dim oILShp As InlineShape
targetHeight = picSize
For Each oShp In Selection.ShapeRange
With oShp
.Width = AspectHt(.Height, .Width, CentimetersToPoints(9))
.Height = CentimetersToPoints(picSize)
End With
Next
For Each oILShp In Selection.InlineShapes
With oILShp
.Width = AspectHt(.Height, .Width, CentimetersToPoints(9))
.Height = CentimetersToPoints(picSize)
End With
Next
End Sub

Private Function AspectHt(ByVal origWd As Long, ByVal origHt As Long, ByVal newWd As Long) As Long
If origWd <> 0 Then
AspectHt = (CSng(origHt) / CSng(origWd)) * newWd
Else
AspectHt = 0
End If
End Function
Diane Poremsky [Outlook MVP]
Outlook Resources: https://www.slipstick.com
https://www.outlook-tips.net


** I don't work for Microsoft.**

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.