Автоматическое изменение размеров ячеек в таблице - PullRequest
Новая
       2

Автоматическое изменение размеров ячеек в таблице

0 голосов
/ 01 декабря 2011

Как автоматически изменить ширину столбца или высоту строки в таблице 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 по отдельности, он делает то, что я хочу, но если я призываю ИТ запустить обе функции друг за другом, он игнорирует часть max_it и, следовательно, size_it не вернется правильный BoundWidth, если клетки "узкие и высокие".

У меня может быть ошибка новичка, например: VBA умный и понимает, что первые изменения max_it будут переделаны на size_it и поэтому игнорирует код (?)

1 Ответ

0 голосов
/ 01 апреля 2016

Я немного искал в интернете, занимался исследованиями и разработками и нашел этот код, который работал на столе. Сценарий состоит в том, что в нем есть слайд и таблица с выбранной строкой. 

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
...