Picture bleeds over to next page

[ABabeNChrist]

What I have is an Excel 2007 worksheet that I enter text on the left side of the worksheet that explains different types of components and just to the right of this text is a merged cell that I used to insert a photo of said component. The problem I’m having is sometimes depending how much text is entered my photo sometimes splits in half and bleeds over to the next page. I know I can go to page break and make changes there but I was hoping for something a little more automatic. Any suggestions?

[HansV]

How does entering text affect the placement of the picture? Do you have code that automatically adjusts the column width?

[ABabeNChrist]

Hi Hans
Here a sample workbook to give you an idea of what I am experiencing. As new info is entered on the row(s) below Description / Observation that uses EntireRow.AutoFit, it then sometimes crops the picture depending on the page break location. I was hoping you knew of a way that if picture was unable to fit it would then go completely to next page. Is there a way to lock the picture cell in a way as to keep intact?

Sample.xlsm

[HansV]

That's one of the disadvantages of merged cells: Excel doesn't split a real cell over two pages but it does allow merged cells to be split. You'll have to check print preview.

[ABabeNChrist]

Something else I noticed was if the separation on to the next page is on the line of the picture on either side (Top or Bottom) it can then also leave a little sliver of the picture on the previous page or continued page. Is this a code issue or?

[HansV]

That's not a code issue. The bottom border of a cell is also the top border of the cell below it. In order to print this border on both pages if there is a page break between the cells, Excel prints a tiny bit of overlap.

[ABabeNChrist]

Thank you Hans

Even with my limited experience with office program it really makes me scratch my head in wonder how complex they are and yet they have so many features that are flawed almost like not fully thought through and almost never seemed to get corrected. I guess if it were a perfect program, there would be no need to buy a newer version.

[ABabeNChrist]

I have a question in regards to this thread. When I mention on post #40357 about a little sliver of the picture on the previous page or continued page, I was wondering is it possible to modify the code alignment on post # 40344 to be slightly below top border that may help any possible overlapping.

[HansV]

You could change

Code: Select all

        With Pic.ShapeRange
            .Left = Target.Left
            .Top = Target.Top
            .LockAspectRatio = msoFalse
            .ZOrder msoBringForward
            If .Width > .Height Then
                .Width = Target.Width
                If .Height > Target.Height Then .Height = Target.Height
            Else
                .Height = Target.Height
                If .Width > Target.Width Then .Width = Target.Width
            End If
        End With

to

Code: Select all

        Const Adjustment = 2
        With Pic.ShapeRange
            .Left = Target.Left
            .Top = Target.Top + Adjustment
            .LockAspectRatio = msoFalse
            .ZOrder msoBringForward
            If .Width > .Height Then
                .Width = Target.Width
                If .Height > Target.Height Then .Height = Target.Height
            Else
                .Height = Target.Height
                If .Width > Target.Width Then .Width = Target.Width
            End If
            .Height = .Height - 2 * Adjustment
        End With

This should push the top of the picture 2 points down and the bottom 2 points up. You can experiment with other values of the Adjustment constant.

[ABabeNChrist]

Thank you Hans
That little sliver of a picture was getting a little annoying, not that is was always happening, but feature prevention is now hopeful, thank you……
I’ll play around with this a bit until I found just the right adjustment.

[Rick Rothstein]

I don't know if this will work for you or not, but the idea behind this macro is to try and move any horizontal page breaks that cut across a picture to the row above the picture. Try the macro out (it assumes your pictures are always place within the borders of a merged cell) on a copy of your worksheet and see if it actually works for you...

Code: Select all

Sub FixPageBreaks()
  Dim X As Long, Shp As Shape
  For X = 1 To ActiveSheet.HPageBreaks.Count
    For Each Shp In ActiveSheet.Shapes
      If Shp.Type = msoPicture Then
        If Not Intersect(ActiveSheet.HPageBreaks(X).Location.EntireRow, Shp.TopLeftCell.MergeArea) Is Nothing Then
          ActiveSheet.HPageBreaks.Add Before:=Shp.TopLeftCell.Offset(-1)
          Exit For
        End If
      End If
    Next
  Next
End Sub

[ABabeNChrist]

Hi Rick
I tried adding the code you suggested along with my code and it seems to only add an additional page break above photo and does not move page break between a photo within a merged cell. Here’s how the code looks along with the suggestion that Hans gave.

Code: Select all

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    If Not Intersect(Range("C42,G42"), Target) Is Nothing Then
        Cancel = True    ' Don't perform the standard action
        ' Your code here; Target is the cell being double-clicked

        Dim Pic As Excel.Picture
        Dim PicLocation As String
        Dim MyRange As Range
        Dim X As Long, Shp As Shape

        PicLocation = Application.GetOpenFilename(FileFilter:="Pic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")

        If PicLocation = "False" Then Exit Sub

        Set Pic = Me.Pictures.Insert(PicLocation)

        Const Adjustment = 2
        With Pic.ShapeRange
            .Left = Target.Left
            .Top = Target.Top + Adjustment
            .LockAspectRatio = msoFalse
            .ZOrder msoBringForward
            If .Width > .Height Then
                .Width = Target.Width
                If .Height > Target.Height Then .Height = Target.Height
            Else
                .Height = Target.Height
                If .Width > Target.Width Then .Width = Target.Width
            End If
            .Height = .Height - 2 * Adjustment
        End With

        With Pic
            .Placement = xlMoveAndSize
            .PrintObject = True
        End With

    End If

    For X = 1 To ActiveSheet.HPageBreaks.Count
        For Each Shp In ActiveSheet.Shapes
            If Shp.Type = msoPicture Then
                If Not Intersect(ActiveSheet.HPageBreaks(X).Location.EntireRow, Shp.TopLeftCell.MergeArea) Is Nothing Then
                    ActiveSheet.HPageBreaks.Add Before:=Shp.TopLeftCell.Offset(-1)
                    Exit For
                End If
            End If
        Next
  Next
End Sub