Тема: Преобразование текста из Frame в обычный текст
Добрый день!
Подскажите по очень важному вопросу. Из учетной программы выгружается документ где все предложения или абзацы находятся в отдельных фреймах Frame и Shape. Невозможно ничего сделать с документом. Хотелось бы чтобы макрос мог сделать документ так как он выглядит на печати но без фреймов, а как обычный построчный текст. Также хотелось бы чтобы внизу где реквизиты работодателя и работника создавалась таблица без видимых границ. Также очень важно сохранить все исходное форматирование (жирность, подчеркивание и т.д.)
Есть вот такой код.
Sub test()
Dim TabHourFrames() As Variant
numb_frames = ActiveDocument.Frames.Count
ReDim TabHourFrames(1 To numb_frames)
counter = numb_frames
For i = 1 To counter
Set myRange = ActiveDocument.Frames.Item(i).Range
t = myRange.Text
TabHourFrames(i) = t
Next i
Documents.Add DocumentType:=wdNewBlankDocument
For q = 1 To counter
last_par = ActiveDocument.Paragraphs.Count
Set rngLastParagraph = ActiveDocument.Paragraphs(last_par).Range
With rngLastParagraph
.InsertAfter Text:=TabHourFrames(q)
.InsertParagraphAfter
End With
Next q
ActiveDocument.Range(0, 0).Select
End Sub
По поиску нашел еще вот такую подобную вещь. Но это не совсем то так как переводит в таблицу все фреймы.
Sub CreateTable()
Dim oS As Frame
Dim sH As String, sV As String, sHeiht As String, sWidth As String, colH As Collection, le As Long, i As Long
Dim avTmp, lMaxColscnt As Long
Dim dicFrames As Object
Dim avItems, avKeys
Dim docNew As Document, oTbl As Table
'словарь рамок
Set dicFrames = CreateObject("scripting.dictionary")
dicFrames.comparemode = 1
On Error Resume Next
For Each oS In ActiveDocument.Frames
sH = oS.HorizontalPosition
sV = oS.VerticalPosition
sHeiht = oS.Height 'вдруг пригодится
sWidth = oS.Width 'вдруг пригодится
avTmp = Array(sH, oS.Range.Text, sHeiht, sWidth)
If dicFrames.Exists(sV) = False Then
Set colH = New Collection
colH.Add avTmp, sH
dicFrames.Add sV, colH
Else
Set colH = dicFrames.Item(sV)
'сортируем столбцы
For i = 1 To colH.Count
If CDbl(sH) < CDbl(colH.Item(i)(0)) Then Exit For
Next
If i > colH.Count Then
colH.Add avTmp, sH
If Err.Number Then
avTmp = Array(sH, avTmp(1) & oS.Range.Text, sHeiht, sWidth)
colH.Item(i) = avTmp
Err.Clear
End If
Else
colH.Add avTmp, sH, Before:=i
If Err.Number Then
avTmp = Array(sH, avTmp(1) & oS.Range.Text, sHeiht, sWidth)
colH.Item(i) = avTmp
Err.Clear
End If
End If
Set dicFrames.Item(sV) = colH
If colH.Count > lMaxColscnt Then
lMaxColscnt = colH.Count
End If
End If
Next
'выгружаем на новую таблицу в новом документе
On Error GoTo 0
avItems = dicFrames.items
avKeys = dicFrames.keys
Set docNew = Documents.Add
Set oTbl = docNew.Tables.Add(docNew.Content, UBound(avKeys), lMaxColscnt)
On Error GoTo 0
For le = LBound(avKeys) To UBound(avKeys)
Set colH = dicFrames.Item(avKeys(le))
For i = 1 To colH.Count
oTbl.Cell(le + 1, i).Range.Text = colH.Item(i)(1)
Next i
Next le
End Sub
Файл во вложении. Помогите пожалуйста)
С уважением, Оксана.