查找列标题高度和行标题宽度

时间:2016-02-29 18:46:18

标签: excel excel-vba vba

这是我上一个问题here的后续行动,但不同的是我觉得提出一个新问题是最好的。我使用了一系列窗口句柄将用户窗体锁定到Excel电子表格,这导致0,0位置位于列和行标题的左上角(或“全选”按钮)。 tl; dr是我试图找到如何确定列标题的高度和行标题的宽度,以便我可以在页面上正确定位用户表单,而不管用户的默认excel字体设置。

我认为我的用户表单到目前为止的代码不会有用,但如果有人愿意,我很乐意发布它。我可以通过将DisplayHeadings属性设置为false来完全删除标题,但这对我的最终目标不起作用。

看起来列标题的高度将等于具有相同字体类型和大小的单元格的默认高度。我没有测试过这种方法,因为它只能给我一半我需要的东西,但我仍然想确认这是否准确。

我也知道行标题的宽度会随着电子表格的进一步变化而变化(例如,首先增加1,000,然后增加10,000,100,000和1,000,000)。我只需要找到最小的宽度(一切都小于1,000),但我想知道如果它不太复杂,如何找到更大的宽度。

要找到标题大小,我尝试通过以下代码删除显示标题后比较单元格的.left和.top属性:

Sub TestHeadings()
   Dim fl, ft, tl, tt As Integer

   tl = Application.ActiveSheet.Range("A1").Left
   tt = Application.ActiveSheet.Range("A1").Top
   Application.ActiveWindow.DisplayHeadings = False
   fl = Application.ActiveSheet.Range("A1").Left
   ft = Application.ActiveSheet.Range("A1").Top

   Debug.Print "True: " & tl & ", " & tt
       'Returns True: 0, 0
   Debug.Print "False: " & fl & ", " & ft
       'Returns False: 0, 0

End Sub

我还尝试通过以下代码比较禁用显示标题后的userform(称为Working_Menu,.StartUpPosition属性设置为0-Manul).left和.top属性:

Sub TestHeadings()
   Dim fl, ft, tl, tt As Integer

   Application.ActiveWindow.DisplayHeadings = False
   With Working_Menu
      .Left = 5 'Also tried 0
      .Top = 5 'Also tried 0
      .Show
    End With
   fl = Working_Menu.Left
   ft = Working_Menu.Top
   Application.ActiveWindow.DisplayHeadings = True
   tl = Working_Menu.Left
   tt = Working_Menu.Top

   Debug.Print "True: " & tl & ", " & tt 
       'Returns True: 5, 145, or 0, 140
   Debug.Print "False: " & fl & ", " & ft 
       'Returns False: 5, 144.75, or 0, 139.5 (Adjusted for screen resolution)

End Sub

我的结果在代码中被注释,但两种方法都没有返回任何指示标题大小的差异。有没有人知道如何确定列标题的高度或行标题的宽度?

谢谢!

1 个答案:

答案 0 :(得分:1)

此Sub将返回其参数HeightPoints(列标题高度,以磅为单位)和WidthPoints(行标题宽度,以磅为单位):

Sub HeadingsSize(ByRef HeightPoints As Single, ByRef WidthPoints As Single)
    Dim rC As Range, bSU As Boolean
    Dim x1 As Long, x2 As Long, y1 As Long, y2 As Long
    Const PxToPt As Single = 72 / 96
    bSU = Application.ScreenUpdating
    If bSU Then Application.ScreenUpdating = False
    With ActiveWindow
        Set rC = .VisibleRange.Cells(1)
        y1 = .PointsToScreenPixelsY(rC.Top)
        x1 = .PointsToScreenPixelsX(rC.Left)
        .DisplayHeadings = Not .DisplayHeadings
        y2 = .PointsToScreenPixelsY(rC.Top)
        x2 = .PointsToScreenPixelsX(rC.Left)
        .DisplayHeadings = Not .DisplayHeadings
    End With
    HeightPoints = Abs(y2 - y1) * PxToPt
    WidthPoints = Abs(x2 - x1) * PxToPt
    Application.ScreenUpdating = bSU
End Sub
相关问题