[ vojvoda1010 @ 13.02.2018. 12:37 ] @
da li moze da se pomocu macro-a uradi kao u prilogu?

Kratko imam vise ovakvih dokumenata treba samo da zadrzim gornji levi ugao i tekst koji je pod 5. ???
[ vojvoda1010 @ 09.09.2018. 09:02 ] @
svaki fajl je razlicite sadrzine i razlicitog broja stranica treba da sadrzi poglavlje/pasus pod rednim brojem 5 i naprd anvedeno
[ bokinet @ 09.09.2018. 15:13 ] @
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

[ vojvoda1010 @ 09.09.2018. 16:26 ] @
da li moze da se prilagodi da iz foldera izvuce sve (vise) eord dokumenta i da ih snimi kad obrise?
[ bokinet @ 09.09.2018. 16:37 ] @
Moze, naravno.
Nesto slicno ste vec trazili i pre, tako da, malo logike i malo individualnog i samostalnog rada ne bi bilo lose da se pokaze sa vase programerske strane...