自动调整表格中的单元格大小答案

【问题标题】：Auto resize cells within table自动调整表格中的单元格大小
【发布时间】：2020-11-30 18:55:51
【问题描述】：

如何在 PowerPoint 表格中自动调整列宽或行高？

编辑：我正在使用 PowerPoint 2010，我想要类似的东西：

Sub table_fix()
 Dim icol As Integer, irow As Integer, minW As Single, minH As Single
 With ActiveWindow.Selection.ShapeRange(1).table
  For icol = 1 To .Columns.Count
   For irow = 1 To .Rows.Count
    With .Cell(irow, icol).Shape.TextFrame
     If minW = 0 Then minW = .TextRange.BoundWidth + .MarginLeft + .MarginRight
     If minW < .TextRange.BoundWidth + .MarginLeft + .MarginRight Then minW = .TextRange.BoundWidth + .MarginLeft + .MarginRight
    End With
   Next
   .Columns(icol).Width = minW
  Next
 End With
 With ActiveWindow.Selection.ShapeRange(1).table
  For irow = 1 To .Rows.Count
   For icol = 1 To .Columns.Count
    With .Cell(irow, icol).Shape.TextFrame
     If minH = 0 Then minH = .TextRange.BoundHeight + .MarginTop + .MarginBottom
     If minH < .TextRange.BoundHeight + .MarginTop + .MarginBottom Then minH = .TextRange.BoundHeight + .MarginTop + .MarginBottom
    End With
   Next
   .Rows(irow).Height = minH
  Next
 End With
End Sub

此代码不会修复所有列宽和所有行高。当列又窄又高时，它会在调整哪些列的大小时出现一些混乱，并且有时会在某些数字上添加随机空格。

我希望我可以模拟“通过双击边框来调整单元格的大小”。我相信我需要对 BoundWidth 和 BoundHeight 进行某种迭代计算，或者 2010 年是否有我最初搜索的功能？

编辑 2：我已拆分代码进行测试：

Sub IT()
 Dim icol As Integer, irow As Integer, minW As Single, minH As Single
 Call max_it
 Call size_it
End Sub

Function max_it()
 With ActiveWindow.Selection.ShapeRange(1).table
  For icol = 1 To .Columns.Count
   .Columns(icol).Width = 1000
  Next
 End With
End Function

Function size_it()
 With ActiveWindow.Selection.ShapeRange(1).table
  For icol = 1 To .Columns.Count
   For irow = 1 To .Rows.Count
    With .Cell(irow, icol).Shape.TextFrame
     If minW = 0 Then minW = .TextRange.BoundWidth + .MarginLeft + .MarginRight
     If minW < .TextRange.BoundWidth + .MarginLeft + .MarginRight Then minW = .TextRange.BoundWidth + .MarginLeft + .MarginRight
    End With
   Next
   .Columns(icol).Width = minW
   minW = 0
   If icol < .Columns.Count Then .Columns(icol + 1).Width = 1000
  Next
  For irow = 1 To .Rows.Count
   For icol = 1 To .Columns.Count
    With .Cell(irow, icol).Shape.TextFrame
     If minH = 0 Then minH = .TextRange.BoundHeight + .MarginTop + .MarginBottom
     If minH < .TextRange.BoundHeight + .MarginTop + .MarginBottom Then minH = .TextRange.BoundHeight + .MarginTop + .MarginBottom
    End With
   Next
   .Rows(irow).Height = minH
  Next
 End With
End Function

当我分别运行 max_it 和 size_it 时，它会执行我想要的操作，但如果我调用 IT 依次运行这两个函数，它会忽略 max_it 部分，因此 size_it 将不会返回如果单元格“又窄又高”，则为正确的BoundWidth。

我可能有一些初学者的错误，例如：VBA 很聪明，并意识到第一个 max_it 更改将由 size_it 重做，因此忽略了代码 (?)

【问题讨论】：

“自动调整大小”到底是什么意思？您的意思是要通过代码（即自动化流程）或其他方式调整表格的大小？此外，最好总是提及您正在使用的 PPT 版本以及您的代码需要支持的版本。
我通过设置 minW/minH = 0 来修复“随机”螺丝起落，在它们被分配到宽度/高度之后。在窄高单元格上，我试图在检查边界宽度之前为单元格宽度分配巨大的值，但这在一次运行中不起作用。如果我首先运行一个扩大列的宏，然后我的它很好，但是在一个宏中（即使有两个单独的函数）它不起作用，有什么帮助吗？
您是否启用了任何错误捕获？ 2007 年和 2010 年的表格对象模型从未正确完成，尤其是当您进入 Shape 级别时。 Intellisense/文档中出现的许多属性/方法在涉及表格单元格形状时根本不起作用。代码将编译，但在遇到某些语句时会出错。如果您的代码在 On Error Resume Next 上下文中运行，您将不会看到任何错误。
完全没有错误，它似乎忽略了我在尝试找到最小宽度之前先增加宽度（这对我来说似乎是获得“自动宽度”的最佳方式，因为BoundWWidth 将返回单元格需要的宽度，而不是它当前拥有的空间，如果我不先加宽单元格，它会这样做）
我终于有时间再次研究这个问题，但仍然无处可解决。我在寻找最小宽度之前添加了一条线来增加列的宽度，但是 VBA 似乎无法读出正确的边界宽度，我可以以某种方式重新加载边界宽度数据（我假设它在调整大小之前使用了边界宽度...

标签： vba powerpoint

【解决方案1】：

我在互联网上搜索了一下，做了一些研发，发现这段代码在一张桌子上工作。场景是其中有一张幻灯片和一个表格，其中选择了一行。

Sub Spacer_Row() 'backup
Dim Sld As Slide
Dim Shp As Shape
Dim tabs As table
Dim lRow As Long
Dim lCol As Long
'Table row formatting
On Error GoTo Select_Object
With ActiveWindow.Selection
If .ShapeRange.Type = msoTable Then
Set tabs = .ShapeRange.table
For lRow = 1 To tabs.Rows.Count
 For lCol = 1 To tabs.Columns.Count
  If tabs.Cell(lRow, lCol).Selected Then
   With tabs.Cell(lRow, lCol).Shape
    tabs.Cell(lRow, lCol).Shape.TextFrame2.MarginBottom = 0.7
    tabs.Cell(lRow, lCol).Shape.TextFrame2.MarginTop = 0.6
    tabs.Cell(lRow, lCol).Shape.TextFrame.TextRange.Font.Size = 1
    tabs.Rows(lRow).Height = 0.2
    tabs.Cell(lRow, lCol).Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
   End With
  End If
 Next
Next
Exit Sub
End If
Select_Object:
 MsgBox "Select a row to resize" 'Error box asking to select a row
End With
End Sub

【讨论】：

【解决方案2】：

这对我来说仅适用于自动调整列大小，希望有一天有人会补充它来自动调整行大小，基本上当您自动调整列时，它会确保列中的所有单元格最多有 1 行。

使用相同的逻辑，我增加了每个单元格的宽度，直到它只有一行，您可以根据单元格右边框靠近单元格内文本末尾的重要性来更改增量：

For j = 1 To pptTable.Columns(1).Cells.count
    If pptTable.Cell(j, 1).Shape.HasTextFrame Then
    Do While pptTable.Cell(j, 1).Shape.TextFrame.TextRange.Lines.count > 1
        pptTable.Columns(1).Width = pptTable.Columns(1).Width + 5
    Loop
    End If
    'pptCell.Shape.TextFrame.AutoSize = ppAutoSizeShapeToFitText
 Next

您甚至可以通过获取前一个单元格的宽度来使其更好，如果它大于当前单元格的宽度，您只需将其放入并推进for 循环

【讨论】：

【解决方案3】：

我已经试过了，首先找到正确的边界单元格坐标，然后刺激双击它。

Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long

Public Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10

Private Sub SingleClick()
  SetCursorPos 100, 100 'x and y position
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

Private Sub DoubleClick(x, y)
  'Double click as a quick series of two clicks
  SetCursorPos x, y 'x and y position
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

Private Sub RightClick()
  'Right click
  SetCursorPos 200, 200 'x and y position
  mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
End Sub

Public Sub Wait(Seconds As Double)
    Dim endtime As Double
    endtime = DateTime.Timer + Seconds
    Do
        WaitMessage
        DoEvents
    Loop While DateTime.Timer < endtime
End Sub

Sub Button1()
    
    Dim oTbl As Table
    Dim oShp As Shape
    Dim oCell As cell
    'Determine Which Shape is Active
      If ActiveWindow.Selection.Type = ppSelectionShapes Then
        'Loop in case multiples shapes selected
           For Each oShp In ActiveWindow.Selection.ShapeRange
                If oShp.Type = msoTable Then
                    Set oTbl = oShp.Table
                    For lRow = 1 To oTbl.Rows.Count
                        For lCol = 1 To oTbl.Columns.Count
                         If oTbl.cell(lRow, lCol).Shape.HasTextFrame Then
                          With oTbl.cell(lRow, lCol).Shape
                           oTbl.cell(lRow, lCol).Shape.TextFrame.MarginLeft = 5
                           oTbl.cell(lRow, lCol).Shape.TextFrame.MarginRight = 5
                           
                           x = ActiveWindow.PointsToScreenPixelsX(oTbl.cell(lRow, lCol).Shape.Left + oTbl.cell(lRow, lCol).Shape.Width)
                           'need some adjustment
                           If lCol = oTbl.Columns.Count Then x = x - 7 Else x = x - 3
                            
                           y = ActiveWindow.PointsToScreenPixelsY((oTbl.cell(lRow, lCol).Shape.Top + oTbl.cell(lRow, lCol).Shape.Height) / 2)
                           DoubleClick x, y
                            Wait 0.5
                          End With
                          End If
                         Next
                        Next
                End If
           Next oShp
      Else
        MsgBox "There is no shape currently selected!", vbExclamation, "No Shape Found"
      End If
    
End Sub

【讨论】：