Kod koji je prilozen radi fiksnu proveru i analizu na osnovu datih uzoraka (gde pocinje deo koji se izvlaci i deo koji predstavlja gde se izvlacenje zavrsava) za izvlacenje teksta po paragrafima.
Kod se moze adaptirati i privesti nameni posto je dato kao primer.
Pozeljno je kod postaviti u NORMAL template delu dokumenta kako se isti kod ne bi snimao u svaki otvoreni dokument.
Takodje, moguce je napraviti i ADD IN za Word koji bi koristio ovaj kod i tako aktivirao samo po potrebi.
Kod prilikom izvrsavanja, prvo pravi novi dokument na osnovu aktivnog i otvorenog dokumenta i odradjuje sta je potrebno na kopiji.
Ovaj korak se moze promeniti, shodno potrebama...
Pored koda koji radi ekstrakciju (izvlacenje) se nalazi i dati uzorci (1...3) kao i rezultati istih (file-ovi koji se zavrsavaju sa '_extracted_posle.docx').
Sadrzaj BAS file-a koji je prilozen u prilogu kao file je dole takodje u nastavku kao kod.
Code:
' Returns paragraph index number which begins with given string in 'ParagraphBeginWith' if exists
Private Function ParagraphIsBeginWith(ByRef ThisParagraphs As Paragraphs, ParagraphBeginWith As String) As Long
On Error Resume Next
Dim r As Long
Dim lLen As Long
Dim xPar As Paragraph
lLen = Len(ParagraphBeginWith)
' Return value
ParagraphIsBeginWith = 0
For Each xPar In ThisParagraphs
' Update counter
r = r + 1
' If paragraph have text anywhere in paragraph
'If InStr(xPar.Range.Text, ParagraphBeginWith) > 0 Then
' Return value
'ParagraphIsBeginWith = r
'Exit For
'End If
' If paragraph begins with given text
If Left(xPar.Range.Text, lLen) = ParagraphBeginWith Then
' Return value
ParagraphIsBeginWith = r
Exit For
End If
Next
' Free memory resource
Set xPar = Nothing
Err.Clear
End Function
Public Sub ParapgrahExtract()
Dim xDoc As Document
Dim i As Integer
Dim sText As String
Dim sTextBeginWith As String
Dim sTextEndWith As String
Dim lPar(1) As Long
Dim Razlika As Long
Dim bScrUp As Boolean
On Error GoTo ErrHandler
' lPar(0..1) -> Which paragraphs holds part of document which should be extracted and moved to new document
' 1 - 8 -> Paragraphs in document are header of document
' sTextBeginWith -> Paragraph which starts with <Tab> + 5. is beginning of document parth which should be extracted and moved to new document
' sTextEndWith -> Paragraph which ends with <Tab> + 6. is part where extraction parts ends for document parth which should be extracted and moved to new document
' Save current setting of screen updating which is set
bScrUp = Application.ScreenUpdating
DoEvents
' Turn off live screen updating to get on speed
Application.ScreenUpdating = False
' Create new document based on current active document - which will be used as working document
Set xDoc = Application.Documents.Add(ActiveDocument.FullName)
' Make Document active
xDoc.Activate
' Paragraph begin with pattern
sTextBeginWith = vbTab & "5. "
' Paragraph which comes after paragraph which should be extracted
sTextEndWith = vbTab & "6. "
' Get location of paragraph which begins with... --- this is set to be case senstive on lower and upper case letters; function code can be updated to be case insensitive
lPar(0) = ParagraphIsBeginWith(xDoc.Paragraphs, sTextBeginWith)
' Get location of paragraph which ends with... --- this is set to be case senstive on lower and upper case letters; function code can be updated to be case insensitive
lPar(1) = ParagraphIsBeginWith(xDoc.Paragraphs, sTextEndWith)
' If there is no ending paragraph which signals a end of extraction paragraph then set total count of paragraphs in document
If lPar(1) = 0 Then lPar(1) = xDoc.Paragraphs.Count
If lPar(0) > 0 Then
Razlika = lPar(0) - 9
Debug.Print Now, "lpar(0)", lPar(0)
Debug.Print Now, "razlika", Razlika
For i = 1 To Razlika
' Always delete paragraph 9 since we are reducing a number of paragraphs
xDoc.Paragraphs(9).Range.Delete
Next
' Since maybe we delete some paragraphs then we need to recalc locations
' Get location of paragraph which begins with...
lPar(0) = ParagraphIsBeginWith(xDoc.Paragraphs, sTextBeginWith)
' Get location of paragraph which ends with...
lPar(1) = ParagraphIsBeginWith(xDoc.Paragraphs, sTextEndWith)
If lPar(1) = 0 Then lPar(1) = xDoc.Paragraphs.Count
Debug.Print Now, "after lpar(0)", lPar(0)
Debug.Print Now, "after lpar(1)", lPar(1)
Debug.Print Now, "after razlika", Razlika
Razlika = xDoc.Paragraphs.Count - lPar(1)
For i = 0 To Razlika
' Always delete paragraph which is the paragraph that signal the end of part of paragraph which should be extracted
xDoc.Paragraphs(lPar(1)).Range.Delete
Next
End If
' Set back setting for screen updating which was set before
Application.ScreenUpdating = bScrUp
DoEvents
Erase lPar
' Free memory resource
Set xDoc = Nothing
Exit Sub
ErrHandler:
' Show message to user
MsgBox "Doslo je do greske prilikom izvrsavanja koda." & vbCrLf & vbCrLf & "Greska # " & Err.Number & " - " & Err.Description, vbCritical, "ParapgrahExtract"
Debug.Print Now, "Error #"; Err.Number, Err.Description
End Sub