macros resize images

macros_resize_images.bas

Option Explicit

'=== Resize every picture to a % of its ORIGINAL size, then centre it.  ===
'=== Always measured from the original, so repeated runs never compound. ===
'=== Display size only - the embedded image data is untouched.          ===
'=== Enter 100 to reset all pictures back to original size.             ===
'=== Default = your most-used value (ties broken by most recent).       ===
'=== Type CLEAR to forget the history.                                  ===

Public Sub ResizeAllImages()
    Const APPNAME As String = "ResizeImages"
    Const SECT As String = "Usage"

    Dim v As Variant, ks() As String, cs() As Long, sq() As Long
    Dim parts() As String
    Dim i As Long, j As Long, n As Long, top As Long, seq As Long
    Dim tS As String, tL As Long
    Dim hint As String, dflt As String, ans As String
    Dim pct As Single, f As Single
    Dim rng As Range, ils As InlineShape, shp As Shape
    Dim changed As Long

    '--- read history, rank by count then recency ---
    dflt = "80"
    v = GetAllSettings(APPNAME, SECT)

    If Not IsEmpty(v) Then
        n = UBound(v, 1) + 1
        ReDim ks(0 To n - 1): ReDim cs(0 To n - 1): ReDim sq(0 To n - 1)

        For i = 0 To n - 1
            ks(i) = v(i, 0)
            parts = Split(v(i, 1) & "|0", "|")      ' stored as "count|sequence"
            cs(i) = CLng(Val(parts(0)))
            sq(i) = CLng(Val(parts(1)))
            If sq(i) > seq Then seq = sq(i)
        Next i

        For i = 0 To n - 2                          ' sort: count desc, then recency
            For j = 0 To n - 2 - i
                If cs(j) < cs(j + 1) Or _
                   (cs(j) = cs(j + 1) And sq(j) < sq(j + 1)) Then
                    tL = cs(j): cs(j) = cs(j + 1): cs(j + 1) = tL
                    tL = sq(j): sq(j) = sq(j + 1): sq(j + 1) = tL
                    tS = ks(j): ks(j) = ks(j + 1): ks(j + 1) = tS
                End If
            Next j
        Next i

        dflt = ks(0)
        top = IIf(n > 5, 4, n - 1)                  ' show at most 5
        For i = 0 To top
            hint = hint & ks(i) & "% (" & cs(i) & "x)"
            If i < top Then hint = hint & "   "
        Next i
        hint = vbCrLf & vbCrLf & "Most used:  " & hint
    End If

    '--- ask ---
    ans = InputBox("Resize every picture to what percentage of its ORIGINAL size?" _
                   & vbCrLf & "Enter 100 to reset. Type CLEAR to forget history." _
                   & hint, "Resize Images", dflt)

    If Trim$(ans) = "" Then Exit Sub

    If UCase$(Trim$(ans)) = "CLEAR" Then
        DeleteSetting APPNAME
        MsgBox "History cleared.", vbInformation, "Resize Images"
        Exit Sub
    End If

    If Not IsNumeric(ans) Then
        MsgBox "Please enter a number.", vbExclamation, "Resize Images"
        Exit Sub
    End If

    pct = CSng(ans)
    If pct <= 0 Or pct > 100 Then
        MsgBox "Enter a value between 1 and 100.", vbExclamation, "Resize Images"
        Exit Sub
    End If

    '--- remember this choice ---
    tS = CStr(pct)
    seq = seq + 1
    SaveSetting APPNAME, SECT, tS, _
                CStr(CLng(Val(GetSetting(APPNAME, SECT, tS, "0"))) + 1) & "|" & seq

    '--- resize ---
    f = pct / 100
    Application.ScreenUpdating = False
    On Error Resume Next

    For Each rng In ActiveDocument.StoryRanges
        Do
            ' inline pictures (in the text flow)
            For Each ils In rng.InlineShapes
                If ils.Type = wdInlineShapePicture Or _
                   ils.Type = wdInlineShapeLinkedPicture Then

                    ils.LockAspectRatio = msoFalse   ' stop W and H nudging each other
                    ils.ScaleWidth = pct             ' both are % of ORIGINAL
                    ils.ScaleHeight = pct
                    ils.LockAspectRatio = msoTrue

                    ils.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
                    changed = changed + 1
                End If
            Next ils

            ' floating / wrapped pictures
            For Each shp In rng.ShapeRange
                If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then

                    shp.LockAspectRatio = msoFalse
                    shp.ScaleWidth f, msoTrue        ' msoTrue = relative to ORIGINAL
                    shp.ScaleHeight f, msoTrue
                    shp.LockAspectRatio = msoTrue

                    shp.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
                    shp.Left = wdShapeCenter
                    changed = changed + 1
                End If
            Next shp

            Set rng = rng.NextStoryRange
        Loop Until rng Is Nothing
    Next rng

    On Error GoTo 0
    Application.ScreenUpdating = True

    If pct = 100 Then
        MsgBox changed & " picture(s) reset to original size and centred.", _
               vbInformation, "Resize Images"
    Else
        MsgBox changed & " picture(s) set to " & pct & "% of original and centred.", _
               vbInformation, "Resize Images"
    End If
End Sub