Results 1 to 5 of 5
  1. #1
    2 Star Lounger
    Join Date
    Jan 2007
    Location
    Gray, Louisiana, USA
    Posts
    289
    Thanks
    0
    Thanked 0 Times in 0 Posts
    I got this code from the lounge a few 'moons' back
    It is supposed to organize photos that are copied in a worksheet.

    How can it be modified, or what preparations do I need to make prior to executing the macro, to get it to:

    Align photos in the upper left (cell A1) say 3x3 height and width, so I can see all photos that I paste into the sheet aligned down the left column of the sheet.
    The intent then is to add remarks down the side, print to pdf etc.

    This was in a post that I thought answered all the size aligning questions but I can't locate it.
    Thanks





    Sub AdjustShapes()
    Dim shp As Shape
    Dim rng As Range
    Dim sngCWidth As Single
    Dim sngCHeight As Single
    Dim sngSWidth As Single
    Dim sngSHeight As Single
    For Each shp In ActiveSheet.Shapes
    sngSWidth = shp.Width
    sngSHeight = shp.Height
    Set rng = shp.TopLeftCell
    shp.Left = rng.Left
    shp.Top = rng.Top
    sngCWidth = rng.Width
    sngCHeight = rng.Height
    If sngSWidth / sngSHeight > sngCWidth / sngCHeight Then
    sngSHeight = sngSHeight * sngCWidth / sngSWidth
    sngSWidth = sngCWidth
    Else
    sngSWidth = sngSWidth * sngCHeight / sngSHeight
    sngSHeight = sngCHeight
    End If
    shp.Width = sngSWidth
    shp.Height = sngSHeight
    Next shp
    End Sub

  2. #2
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts
    3x3 what? Centimeters, pixels, inches?

    Set the width and height of the cells in column A to what you want, then run the following version of the macro to arrange and fit the pictures (or other shapes) on the sheet into cells A1, A2, ...

    Code:
    Sub AdjustShapes()
      Dim shp As Shape
      Dim rng As Range
      Dim sngCWidth As Single
      Dim sngCHeight As Single
      Dim sngSWidth As Single
      Dim sngSHeight As Single
      Dim i As Integer
      For i = 1 To ActiveSheet.Shapes.Count
    	Set shp = ActiveSheet.Shapes(i)
    	sngSWidth = shp.Width
    	sngSHeight = shp.Height
    	Set rng = Cells(i, 1)
    	shp.Left = rng.Left
    	shp.Top = rng.Top
    	sngCWidth = rng.Width
    	sngCHeight = rng.Height
    	If sngSWidth / sngSHeight > sngCWidth / sngCHeight Then
    	sngSHeight = sngSHeight * sngCWidth / sngSWidth
    	sngSWidth = sngCWidth
    	Else
    	sngSWidth = sngSWidth * sngCHeight / sngSHeight
    	sngSHeight = sngCHeight
    	End If
    	shp.Width = sngSWidth
    	shp.Height = sngSHeight
      Next i
    End Sub

  3. #3
    2 Star Lounger
    Join Date
    Jan 2007
    Location
    Gray, Louisiana, USA
    Posts
    289
    Thanks
    0
    Thanked 0 Times in 0 Posts
    3x3 inches

  4. #4
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts
    Add the following lines to the macro from my previous reply, above For i = 1 To...:

    Code:
      Rows.RowHeight = Application.InchesToPoints(3)
      Columns(1).ColumnWidth = Cells(1, 1).ColumnWidth * _
    	Cells(1, 1).RowHeight / Cells(1, 1).Width

  5. #5
    2 Star Lounger
    Join Date
    Jan 2007
    Location
    Gray, Louisiana, USA
    Posts
    289
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Great, this is a great tool for my audit reports.

    I have it in Personal.xlsm

    Thanks a bunch

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •