ActiveX Textbox Height Width Setting Problem

[Jeffrey Mahoney]

I've struggled with this for a long time and I finally found a way to solve it and it was right under my nose the whole time. When I recorded a macro to change the size of the textbox it provided the .scaleheight method.

I was trying to use ActiveSheet.Shapes(TBName).Height = TextArea.Height. But this most always was a few points off. This is true for setting the width this way. Below I calculate a ratio of target height compared to the textbox height with the scaleheight function and it works every time.

Does anybody know why setting the height or width directly produces random differences? When I changed my zoom setting just right I could get it to the target height.

Sub ResizeTextBoxes()

  Dim TextArea As Range
  Dim TBName As String
  Dim Ratio As Single
  
  
  TBName = "ProblemTB"                                    'Name of textbox
  Set TextArea = Range("ProblemTextArea")                 'Textbox needs to be same size and location as range
  With ActiveSheet.Shapes(TBName)
    .LockAspectRatio = msoFalse                           'Allow height and width to be flexible
    .Left = TextArea.Left                                 'Set left edge to range
    .Top = TextArea.Top                                   'Set top edge to range
    Ratio = TextArea.Height / .Height                     'Height cannot directly be set for some reason
    .ScaleHeight Ratio, msoFalse, msoScaleFromTopLeft     'Using ratio to set the scale height
    Ratio = TextArea.Width / .Width                       'Width cannot directly be set for some reason
    .ScaleWidth Ratio, msoFalse, msoScaleFromTopLeft      'Using ratio to set the scale width
  End With
  
  
  TBName = "RefCaseTB"
  Set TextArea = Range("RefCaseTextArea")
  With ActiveSheet.Shapes(TBName)
    .LockAspectRatio = msoFalse
    .Left = TextArea.Left
    .Top = TextArea.Top
    Ratio = TextArea.Height / .Height
    .ScaleHeight Ratio, msoFalse, msoScaleFromTopLeft
    Ratio = TextArea.Width / .Width
    .ScaleWidth Ratio, msoFalse, msoScaleFromTopLeft
  End With
  
  
  TBName = "BusinessCaseTB"
  Set TextArea = Range("BusinessCaseTextArea")
  With ActiveSheet.Shapes(TBName)
    .LockAspectRatio = msoFalse
    .Left = TextArea.Left
    .Top = TextArea.Top
    Ratio = TextArea.Height / .Height
    .ScaleHeight Ratio, msoFalse, msoScaleFromTopLeft
    Ratio = TextArea.Width / .Width
    .ScaleWidth Ratio, msoFalse, msoScaleFromTopLeft
  End With
  
  
  TBName = "KeyRiskTB"
  Set TextArea = Range("KeyRiskTextArea")
  With ActiveSheet.Shapes(TBName)
    .LockAspectRatio = msoFalse
    .Left = TextArea.Left
    .Top = TextArea.Top
    Ratio = TextArea.Height / .Height
    .ScaleHeight Ratio, msoFalse, msoScaleFromTopLeft
    Ratio = TextArea.Width / .Width
    .ScaleWidth Ratio, msoFalse, msoScaleFromTopLeft
  End With


End Sub

 

[Domenic]

Hi Jeffrey,

As you've already observed, when using the Width and Height properties to adjust the size of the TextBox, its size compared to the range is off somewhat. But the same thing seems to happen when I use your code. However, if I add 0.5 to both the width and height, it seems to work.

  With ActiveSheet.Shapes(TBName)
    .LockAspectRatio = msoFalse                           'Allow height and width to be flexible
    .Left = TextArea.Left                                 'Set left edge to range
    .Top = TextArea.Top                                   'Set top edge to range
    .Width = TextArea.Width + 0.5
    .Height = TextArea.Height + 0.5
  End With

Your code...

My code...

Cheers!

 

[Jeffrey Mahoney]

I've had to add varying values with different zoom levels, and row & column changes

 

[Domenic]

Oh I see, yeah, I just tried it with different zoom levels, and each time it's off somewhat. But it's interesting that for me even using the ScaleWidth and ScaleHeight properties it's still off.

 

[Jaafar Tribak]

Notice that this issue doesn't happen with non-oleobject shapes ... You are setting the Width & Height of the wrapper shape object, not the actual textbox ... *Maybe*, this is the reason for the inaccuracy in measurement. Casting the shape object to the oleobject seems to fix the issue regardless of the worksheet zoom.

Sub ResizeTextBoxes()
    Dim TextArea As Range
    Dim TBName As String
    TBName = "ProblemTB"
    Set TextArea = Range("ProblemTextArea")
    With ActiveSheet.Shapes(TBName)
        .LockAspectRatio = msoFalse
        .Left = TextArea.Left
        .Top = TextArea.Top
        'Cast Shape object to OLEObject
        Dim oTxtOLEObj As OLEObject
        Set oTxtOLEObj = .OLEFormat.Object
        With oTxtOLEObj
            .Height = TextArea.Height
            .Width = TextArea.Width
        End With
    End With
End Sub

 

[Edgar_]

OK, so, I created an ActiveX Textbox, a Rectangle and a normal TextBox; I named them object1, object2 and object3, respectively. After that, I removed the borders to see the effect better (the ActiveX textbox couldn't have its borders removed, instead, I set the border style to single and its color to white).

Then, I created this little function:

Sub MatchRangeObjectSize(rng As Range, obj As Object)
    With obj
        .Left = rng.Left
        .Top = rng.Top
        .Height = rng.Height
        .Width = rng.Width
    End With
End Sub

I called it as follows:

Sub Matching()
    MatchRangeObjectSize [B2:B5], [object1]
    MatchRangeObjectSize [D2:D5], [object2]
    MatchRangeObjectSize [F2:F5], [object3]
End Sub

I got this:

They all looked the same, so I created the following function next:

Sub MatchRangeObjectSize2(rng As Range, obj As Object)
    With obj.ShapeRange
        .Left = rng.Left
        .Top = rng.Top
        .ScaleHeight rng.Height / .Height, msoFalse, msoScaleFromTopLeft
        .ScaleWidth rng.Width / .Width, msoFalse, msoScaleFromTopLeft
    End With
End Sub

And I called it like this after moving and resizing the objects:

Sub Matching2()
    MatchRangeObjectSize2 [B2:B5], [object1]
    MatchRangeObjectSize2 [D2:D5], [object2]
    MatchRangeObjectSize2 [F2:F5], [object3]
End Sub

This is the result

Same thing, again.

Next, I tried to check what the result of snapping to the grid would be. So I went ahead and snapped object3, the regular Textbox, to some cell. After snapping, I checked the positioning from the immediate window and everything matched:

    ? [object3].Top = [L4].Top
    TRUE
    ? [object3].Left = [L4].Left
   TRUE
    ? [object3].Height = [L4].Height
   TRUE
    ? [object3].Width = [L4].Width
   TRUE

I got True for all of them.

By the way, the debugger returned the following types for my objects:
object1, the ActiveX Textbox: OLEObject
object2, the Rectangle shape: Rectangle
object3, the regular Textbox: Textbox

My verdict after this test? if you add a simple border, nothing is off, so if you don't want this behavior to bother you, add the simple border, because not adding it seems to leave the right and bottom borders visible while the left and top are invisible. It looks like this:

I'm using Excel 2016 for this test and I repeat, all 3 tested methods return the same result at 100% Zoom, which I know is the true view.

 

[Domenic]

After doing a bit more testing, it looks like the only way I can get an exact fit is by adding 0.5 points to both the width and height properties. However, with different zoom levels, none of them seem to work for me.

[Before]

[OleObject using Width and Height Properties]

[Shape using Width and Height Properties]

[Shape using ScaleWidth and ScaleHeight Properties]

[Shape using Width + 0.5 and Height + 0.5]

 

[Edgar_]

In the Excel grid, each line is one pixel thick, If you zoom enough, you will see that the left/top snaps to a 1-pixel corner of the grid. See the image.

In my case, I don't see anything "off". So, my suggestion for this is: whatever you want to do to display your shape, it will have to account for that 1-pixel-thick-grid.

 

[Jeffrey Mahoney]

@Edgar_ I tried duplicating your process using objects to resize. In all cases my results varied. For me, using ScaleWidth and ScaleHeight worked every time.

@Jaafar Tribak - I also tried the OLEObject method with no luck.

It is strange that several people had to use different methods to achieve the same thing.

 

[Jeffrey Mahoney]

As long as were talking about this; I was working on resizing charts to fit ranges also. These are a little different animal in that the Plot Area and Legend Area are relative to the Chart Area.

Setting Zoom to 100% temporarily gave me accurate results. There is an additional offset between the edges of the Chart Area and the Plot & Legend Areas. To find that I set the left plot edge to -100 temporarily to get the offset. In these cases it ended up being an offset of 4 points.

Sub ResizeCharts()
  Dim ASht As Worksheet              'Worksheet variable
  Dim ChrtObj As ChartObject         'Chart Object
  Dim Chrt As Chart                  'Working chart
  Dim Astr As String                 'String Variable
  Dim ChartBaseName As String
  Dim ChartFullName As String
  Dim ChrtArea As Range
  Dim ChrtPlot As Range
  Dim ChrtLeg As Range
  Dim Ratio As Double
  Dim Shp As Shape
  Dim PlotLeftOffset As Double
  Dim PlotTopOffset As Double
  

                                      
  Set ASht = Charts40
  ASht.Activate
  CurZoom = ActiveWindow.Zoom         'Save  zoom level till later
  ActiveWindow.Zoom = 100             '100% works best for placement
  DoEvents
  
  For Each ChrtObj In ASht.ChartObjects
    Set Chrt = ChrtObj.Chart
    'Debug.Print Chrt.Name
    Astr = Chrt.Name
    ChartFullName = Mid(Astr, InStr(Astr, "Chart"), 100)                             'Chart names are Chart1-1 ... Chart2-6
    ChartBaseName = Replace(Replace(Replace(ChartFullName, " ", ""), "-", ""), "Chart", "Chrt")
    
    Set ChrtArea = ASht.Range(ChartBaseName & "Area")   'Named range for each chart is Chrt11Area ... Chrt26Area
    Set ChrtPlot = ASht.Range(ChartBaseName & "Plot")   'Named range for each chart is Chrt11Plot ... Chrt26Plot
    Set ChrtLeg = ASht.Range(ChartBaseName & "Leg")     'Named range for each chart is Chrt11Leg ... Chrt26Leg
    Set Shp = ASht.Shapes(ChartFullName)
    Shp.LockAspectRatio = msoFalse
    
    Chrt.ChartArea.Top = ChrtArea.Top
    Chrt.ChartArea.Left = ChrtArea.Left
    Ratio = (ChrtArea.Height - 5) / Chrt.ChartArea.Height   'Setting Height directly doesn't work. Added 5 points
    Shp.ScaleHeight Ratio, msoFalse, msoScaleFromTopLeft
    Ratio = (ChrtArea.Width - 5) / Chrt.ChartArea.Width     'Setting Height directly doesn't work. Added 5 points
    Shp.ScaleWidth Ratio, msoFalse, msoScaleFromTopLeft
    
    
    With Chrt.PlotArea
      .Left = -100                         'Force left edge to be adjacent to left edge of chart area
      PlotLeftOffset = -.Left         'Used to get exact left edge of intended range for plot area
      .Top = -100                         'Force top edge to be adjacent to top edge of chart
      PlotTopOffset = -.Top           'Used to set plot to exact top edge of plot range
      .InsideLeft = ChrtPlot.Left - Chrt.ChartArea.Left - PlotLeftOffset  'Use Inside left edge
      .InsideTop = ChrtPlot.Top - Chrt.ChartArea.Top - PlotTopOffset      'Use Inside top edge
      .InsideHeight = ChrtPlot.Height                                     'Height falls into place now
      .InsideWidth = ChrtPlot.Width                                       'Width falls into place now
    End With
    
    With Chrt.Legend
      .Left = ChrtLeg.Left - Chrt.ChartArea.Left - PlotLeftOffset     'The PlotOffset works here also
      .Top = ChrtLeg.Top - Chrt.ChartArea.Top - PlotTopOffset
      .Height = ChrtLeg.Height
      .Width = ChrtLeg.Width
    End With
    
  Next ChrtObj

  
  Application.GoTo Range("A10"), True
  ActiveWindow.Zoom = CurZoom
  
End Sub