Цитата |
---|
bedvit написал: Большая работа проведена. |
Привет, Виталий.
Да, не особо. Делать полноценный chm со станицами список функций, функции по категориям с перекрёстными ссылками не стал - тут действительно пришлось бы повозиться. А так, код для загруженной в Word страницы списка функций
Скрытый текст |
---|
Код |
---|
Public Sub tryCreate()
Dim pHyp As Hyperlink, newFileName As String
Dim outPath As String
Dim newDoc As Document
outPath = ThisDocument.Path & "\funcs\"
For Each pHyp In ThisDocument.Hyperlinks
If InStr(pHyp.Address, "-функция") > 0 Then
newFileName = Replace$(Replace$(pHyp.Range.Text, vbLf, ""), vbCr, "") & ".docx"
Set newDoc = Application.Documents.Open(pHyp.Address)
delTopParagraphs newDoc
delLastParagraphs newDoc
newDoc.SaveAs2 outPath & newFileName, WdSaveFormat.wdFormatXMLDocument, SaveFormsData:=False
newDoc.Close
'Stop
End If
Next
End Sub
Public Sub delTopParagraphs(ByVal inDoc As Document)
Dim pPara As Paragraph, counter As Long, i As Long
counter = 0
For Each pPara In inDoc.Paragraphs
If pPara.Format.OutlineLevel = wdOutlineLevel1 Then
Exit For
End If
counter = counter + 1
Next
For i = counter To 1 Step -1
inDoc.Paragraphs(i).Range.Delete
Next
End Sub
Public Sub delLastParagraphs(ByVal inDoc As Document)
Dim counter As Long, i As Long, pPara As Paragraph
counter = 0
For Each pPara In inDoc.Paragraphs
counter = counter + 1
If InStr(pPara.Range.Text, "Совершенствование навыков работы с Office") = 1 Then
Exit For
End If
Next
For i = inDoc.Paragraphs.Count To counter Step -1
inDoc.Paragraphs(i).Range.Delete
Next
End Sub
Public Sub dropEmptyHyperLinks()
Dim pHyp As Hyperlink, sAddress As String
For Each pHyp In ThisDocument.Hyperlinks
sAddress = pHyp.Address
If InStr(1, sAddress, "https://") = 0 Then
pHyp.Delete
End If
Next
End Sub |
|
Как видишь - код удаления ненужных параграфов в тексте описания функции - лобовой. Не нашёл (особо не искал), как задать диапазон параграфов.
После сохранения доков по каждой функции примитивно через Ctrl+C, Ctrl+V было собрано в один документ.
Скрытый текст |
---|
Код |
---|
Public Sub mergeDocs()
Dim pHyp As Hyperlink, newFileName As String
Dim inPath As String, newDoc As Document
Dim nextDoc As Document, vCount As Long
Dim pPara As Paragraph
inPath = ThisDocument.Path & "\funcs\"
Set newDoc = Application.Documents.Add
For Each pHyp In ThisDocument.Hyperlinks
If InStr(pHyp.Address, "-функция") > 0 Then
newFileName = Replace$(Replace$(pHyp.Range.Text, vbLf, ""), vbCr, "") & ".docx"
Set nextDoc = Application.Documents.Open(inPath & newFileName)
Set pPara = newDoc.Paragraphs.Add
nextDoc.Range.Copy
pPara.Range.Paste
nextDoc.Close False
vCount = vCount + 1
DoEvents
End If
Next
End Sub |
|
Почему-то стандартное для Word слияние Вставка/Объект/Текст из файла одновременно больше 50 файлов соединять не захотело.