自动调整表格内的单元格大小

Question

如何在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将不会返回正确的size_it。

我可能有一些初学者的错误，比如：VBA很聪明，并且意识到第一个max_it更改将由{{1}}重做，因此会忽略代码（？）

Answer 1

我在互联网上搜索了一下并做了一些R＆amp; D，发现这个代码在桌子上工作。方案是有一个幻灯片和一个表格，其中选择了一行。

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

Answer 2

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

使用相同的逻辑，我增加了每个单元格的宽度，直到只有一行为止，您可以根据使单元格右边界靠近单元格中文本结尾的严格程度来更改增量： / p>

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循环

Answer 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