Изменение текста в элементе управления контентом происходит очень медленно

Question

У меня есть большая таблица в ms-word, содержащая 85 элементов управления содержимым (поля со списком). Я хочу изменить содержимое, используя vba l oop (см. Ниже). На это уходит больше одной минуты ... Есть ли другие варианты?

Private Sub Btn_Clear1_Click()
    
    Dim a
    Dim c As ContentControl

    a = FindTable(ActiveDocument.Name, "myTableName")(1) 'returns an array(Long) with number of table found
    
    For Each c In ActiveDocument.Tables(a).Range.ContentControls
        c.Range.text = "MY CHANGED TEXT"
    Next c

End Sub

Заранее благодарим за любую подсказку!

Answer 1

Здесь отключение обновления экрана сокращает время примерно с 6 секунд до менее 1 секунды. например,

On Error Goto turnscreenon
Application.Screenupdating = False
For Each c In ActiveDocument.Tables(a).Range.ContentControls
    c.Range.text = "MY CHANGED TEXT"
Next c
turnscreenon:
Application.Screenupdating = True

Это может работать только в версии Word Windows.

Если вы точно знаете, сколько полей со списком будет, вы можете подумать о создании настраиваемого xml часть, содержащая массив XML элементов для хранения значений. Сопоставьте каждый элемент управления содержимым с одним из этих элементов. Затем вместо записи значений в диапазоны управления содержимым запишите их в часть XML, и пусть Word выполнит эту работу. Здесь это работает почти мгновенно.

например, в простом сценарии, где у вас есть только эти 85 элементов управления содержимым в таблице, вы можете настроить Custom XML Part следующим образом (я оставляю вас писать любой код, который нужно удалить старые версии). Вам нужно будет запустить это только один раз.

Sub createCxpAndLink()
' You should choose your own Uri
Const myNamespaceUri As String = "mycbcs"
Dim a
Dim i As Long
Dim s As String
Dim cxp As Office.CustomXMLPart

With ActiveDocument
  a = FindTable(.Name, "myTableName")(1)
  s = ""
  s = s & "<?xml version='1.0' encoding='UTF-8'?>" & vbCrLf
  s = s & "<cbcs xmlns='" & myNamespaceUri & "'>" & vbCrLf
  For i = 1 To .Tables(a).Range.ContentControls.Count
    s = s & "  <cbc/>" & vbCrLf
  Next
  s = s & "</cbcs>"

  Set cxp = .CustomXMLParts.Add(s)
  With .Tables(a).Range.ContentControls
    For i = 1 To .Count
      .Item(i).XMLMapping.SetMapping "/x:cbcs[1]/x:cbc[" & Trim(CStr(i)) & "]", "xmlns:x='" & myNamespaceUri & "'", cxp
    Next
  End With
  Set cxp = Nothing
End With

End Sub

Затем для обновления содержимого вам понадобится что-то вроде этого

Sub testsetxml()
Const myNamespaceUri As String = "mycbcs"
Dim i As Long
'our start time...
Debug.Print Now
With ActiveDocument.CustomXMLParts.SelectByNamespace(myNamespaceUri)(1)
  For i = 1 To 85
    .SelectNodes("/ns0:cbcs[1]/ns0:cbc[" & Trim(CStr(i)) & "]")(1).Text = "my changed text "  

    ' or if you want to put different texts in different controls, you can test using e.g.
    .SelectNodes("/ns0:cbcs[1]/ns0:cbc[" & Trim(CStr(i)) & "]")(1).Text = "my changed text " & Cstr(i)
  Next
End With
'our end time...
Debug.Print Now

End Sub

(NB, вы не можете сделать это, сопоставив все элементы управления для одного элемента XML, потому что тогда все раскрывающиеся списки будут обновляться до одного и того же значения всякий раз, когда вы изменяете значение одного из них.)

Извинения за любые опечатки - я изменил код, чтобы он больше соответствовал тому, что вы уже использовали, и не тестировал изменения.