Jaroslav Macro 2019 - vSept_26_2019

'MACRO VERSION: vSept_26_2019 (UPDATED 26 Sept 2019)
'1) SWITCH KEYBOARD/WINDOWS LANGUAGE TO RUSSIAN
'BEFORE COPYING (AND PASTING) THIS MACRO!!!
'2). Word Object Model Changes (Word 2000 is VBA 6.0, Word 2010 is VBA 7.0, W2016=7.1)
'https://msdn.microsoft.com/en-us/library/office/bb149069(v=office.12).aspx
Sub Digest_Formatter_MACRO_vSept_26_2019()

'Enable error-handling routine
On Error GoTo AnyErrorHadler


'Disable MRU Files list
'Application.RecentFiles.Maximum = 0

    'copy-paste all into new document
    Selection.WholeStory
    Selection.Copy
    'clear selection in orig doc to save mem
    Selection.HomeKey Unit:=wdStory 'go home (top)
    Documents.Add DocumentType:=wdNewBlankDocument
    Selection.PasteAndFormat (wdUseDestinationStylesRecovery)
    'Clear Undo history for THIS doc ONLY
    'b/c huge copied text chunk clogs memory
    ActiveDocument.UndoClear


    ' check MS Word version
    ' CURRENTLY NOT USED
    Select Case Application.Version
     Case "16.0"
       msWordVersion = "MS Word 2016 / Office 365 / Word 2019"
    Case "15.0"
       msWordVersion = "MS Word 2013"
    Case "14.0"
        msWordVersion = "MS Word 2010"
    ' 13.0 is missing  (Microsoft skipped 13)
    Case "12.0"
        msWordVersion = "MS Word 2007"
    Case "11.0"
        msWordVersion = "MS Word 2003"
    Case "10.0"
        msWordVersion = "MS Word 2002 (aka  Word XP)"
    Case "9.0"
        msWordVersion = "MS Word 2000"
    Case "8.0"
        msWordVersion = "MS Word 97"
    Case "7.0"
        msWordVersion = "MS Word 95"
    End Select


    'Application.System.Version RETURNS:
    ' "6.1" on Windows 7 and "6.2" on Windows 8
    ' 10.0 on Windows 10

'*******************************************************************
'********MAIN LOGIC START*******************************************
'*******************************************************************

    'position cursor at HOME (doc start)
    Selection.HomeKey Unit:=wdStory 'go home (top)

    'check if doc-to-process has TOC => check 3 markers:

    'check FirstMarkerPhrase
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Bold = True
    End With
    With Selection.Find
        .Text = "Департамент корпоративных коммуникаций"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
   isHasFirstMarkerPhrase = Selection.Find.Execute

   '.Text = "Департаменткорпоративныхкоммуникаций" глюк
   If isHasFirstMarkerPhrase = False Then
       Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Bold = True
    End With
    With Selection.Find
        .Text = "Департаменткорпоративныхкоммуникаций"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    isHasFirstMarkerPhrase = Selection.Find.Execute
   End If

    'check SecondMarkerPhrase
    Selection.HomeKey Unit:=wdStory 'go home (top)

    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Bold = True
    End With
    With Selection.Find
        .Text = "МОНИТОРИНГ СМИ"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
   isHasSecondMarkerPhrase = Selection.Find.Execute

   '.Text = "МОНИТОРИНГСМИ" глюк
   If isHasSecondMarkerPhrase = False Then
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Bold = True
    End With
    With Selection.Find
        .Text = "МОНИТОРИНГСМИ"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    isHasSecondMarkerPhrase = Selection.Find.Execute
   End If


   'check ThirdMarker - Column Separator
    Selection.HomeKey Unit:=wdStory 'go home (top)

   Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^n"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
    End With
    isHasThirdMarker = Selection.Find.Execute

    'Remove TOC (if doc-to-process has any TOC)
    If isHasFirstMarkerPhrase And isHasSecondMarkerPhrase And isHasThirdMarker Then
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^n"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
    Selection.Delete Unit:=wdCharacter, Count:=1
    Selection.Delete Unit:=wdCharacter, Count:=1
    End If


    ' BELOW PROCESSING LOGIC IS SAME FOR ANY DOCUMENT
    '***************************************************************************

    Dim articleCounter As Integer

    'position cursor at HOME (doc start)
    Selection.HomeKey Unit:=wdStory

    Dim isMoreMainHeadersPresent As Boolean 'defaults to FALSE

    'loop all MAIN HEADERs and
    'process ONLY first article after each MAIN HEADER.
    'Add no empty paragraphs as separators!
    Do
'FIND MAIN HEADER
'1.1. setup search
        Selection.Find.ClearFormatting
        With Selection.Find.Font
            .Size = 20
            .Bold = True
            .Italic = True
            .Underline = True
            .Name = "Georgia"
        End With
'1.2. do search (for main header).
'search formatting only: FindText:=""
        isMoreMainHeadersPresent = Selection.Find.Execute(FindText:="")

        'ГЛЮК: Word 2002 + docx plugin Font Size is 16, not 20 (as in higher Word) !!!
        If isMoreMainHeadersPresent = False Then
            Selection.Find.Font.Size = 16
            isMoreMainHeadersPresent = Selection.Find.Execute(FindText:="")
        End If


        If isMoreMainHeadersPresent Then

'DELETE FOUND MAIN HEADER
            Selection.Delete

'select line/para immediately after deleted MAIN HEADER
'(including paragraph sign)
            Selection.Expand wdParagraph
            'Selection.EndKey Unit:=wdLine, Extend:=wdExtend 'Fails with multi-line para

'PARSE/FIND: http://on-line-teaching.com/vba/lsn0107.html

'parse article header
'(save the line/para selected above to variable)
            initialTitleStr = Selection.Range.Text
'construct wanted title string.
'( _SERVICE$SOURCE#MARK_ will be replaced
'to "Заглавие:  " + 2 preceeding para marks later)
            resultingTitleStr = "Заглавие: " + initialTitleStr
'Delete (previously selected) header line (paragraph)
            Selection.Delete

'select line/para immediately after deleted
'article header line (including paragraph sign)
            Selection.Expand wdParagraph
            'Selection.EndKey Unit:=wdLine, Extend:=wdExtend

            initiaDateAndSourceString = Selection.Range.Text

            Dim dateAndSourceStringLength As Integer

            dateAndSourceStringLength = Len(initiaDateAndSourceString)

            'some reasonable length enough to contain valid date and source
            If (dateAndSourceStringLength > 8) Then

            'split string containing date and source into parts by comma separator
            Dim dateAndSrcStrElements() As String
            dateAndSrcStrElements = Split(initiaDateAndSourceString, ",")

            If (InStr(dateAndSrcStrElements(0), " ") <> 0) Then
              'first comma-separated block contains space =>
              'discard everything after space, and use everything before space as wanted date
              Dim parts() As String
              parts = Split(dateAndSrcStrElements(0), " ")
              parsedDateWithoutTime = parts(0)
            Else
            'first comma-separated block is already wanted date
              parsedDateWithoutTime = dateAndSrcStrElements(0)
            End If


            If (InStr(dateAndSrcStrElements(1), ":") <> 0) Then
              'second comma-separated block is time
              'discard this block completely
              'TODO: MAYBE LATER THIS BLOCK WOULD HAVE NEEDED INFO - IF FORMAT LATER CHANGES
              parsedSource = dateAndSrcStrElements(2)
            Else
            'second comma-separated block is already wanted source
              parsedSource = dateAndSrcStrElements(1)
            End If


             If ((InStr(parsedSource, vbCrLf) = 0) And (InStr(parsedSource, vbCr) = 0) And (InStr(parsedSource, vbLf) = 0)) Then
                parsedSource = parsedSource + vbCrLf
            End If


            resultingDateAndSourceText = "_SERVICE$SOURCE#MARK_" + parsedSource

            resultingDateAndSourceText = resultingDateAndSourceText + "Дата выпуска: " + parsedDateWithoutTime + vbCrLf

            Selection.Range.Text = resultingDateAndSourceText + resultingTitleStr

            articleCounter = articleCounter + 1

        End If

       End If  'If (dateAndSourceStringLength > 8) Then

    Loop While isMoreMainHeadersPresent
    'Now loop Headers of Remaining Articles
    'process all respective articles
    'Add no empty paragraphs as separators!
    Selection.HomeKey Unit:=wdStory 'GO HOME (top of file) FIRST TO SEARCH FROM BEGINNING

    Do
'FIND Article header
'1.1. setup search
        Selection.Find.ClearFormatting
         With Selection.Find.ParagraphFormat
        .SpaceBefore = 12
    End With
'1.2. do search (for regular article header).
'search formatting only: FindText:=""
        isMoreArticleHeadersPresent = Selection.Find.Execute(FindText:="")

        If isMoreArticleHeadersPresent Then

'parse article header
'(save the line/para selected above to variable)
            initialTitleStr = Selection.Range.Text
'construct wanted title string.
'( _SERVICE$SOURCE#MARK_ will be replaced
'to "Заглавие:  " + 2 preceeding para marks later)
            resultingTitleStr = "Заглавие: " + initialTitleStr
'Delete (previously selected) header line (paragraph)
            Selection.Delete

'select line/para immediately after deleted
'article header line (including paragraph sign)
            Selection.Expand wdParagraph
            'Selection.EndKey Unit:=wdLine, Extend:=wdExtend

            initiaDateAndSourceString = Selection.Range.Text

                      'split string containing date and source into parts by comma separator

            dateAndSrcStrElements = Split(initiaDateAndSourceString, ",")

            If (InStr(dateAndSrcStrElements(0), " ") <> 0) Then
              'first comma-separated block contains space =>
              'discard everything after space, and use everything before space as wanted date
              parts = Split(dateAndSrcStrElements(0), " ")
              parsedDateWithoutTime = parts(0)
            Else
            'first comma-separated block is already wanted date
              parsedDateWithoutTime = dateAndSrcStrElements(0)
            End If


            If (InStr(dateAndSrcStrElements(1), ":") <> 0) Then
              'second comma-separated block is time
              'discard this block completely
              'TODO: MAYBE LATER THIS BLOCK WOULD HAVE NEEDED INFO - IF FORMAT LATER CHANGES
              parsedSource = dateAndSrcStrElements(2)
            Else
            'second comma-separated block is already wanted source
              parsedSource = dateAndSrcStrElements(1)
            End If

              If ((InStr(parsedSource, vbCrLf) = 0) And (InStr(parsedSource, vbCr) = 0) And (InStr(parsedSource, vbLf) = 0)) Then
                parsedSource = parsedSource + vbCrLf
            End If

            resultingDateAndSourceText = "_SERVICE$SOURCE#MARK_" + parsedSource

            resultingDateAndSourceText = resultingDateAndSourceText + "Дата выпуска: " + parsedDateWithoutTime + vbCrLf

            Selection.Range.Text = resultingDateAndSourceText + resultingTitleStr

            articleCounter = articleCounter + 1

        End If
    Loop While isMoreArticleHeadersPresent



    'Now Replace
    '_SERVICE$SOURCE#MARK_
    'to "Заглавие:  " + add 2 preceeding para marks)
    Selection.HomeKey Unit:=wdStory  'GO HOME (top of file) - not neccesary, but just in case
    'Replace
        Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_SERVICE$SOURCE#MARK_"
        .Replacement.Text = "^p^pИсточник:"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll


     Selection.HomeKey Unit:=wdStory 'go home - top of doc
     'delete 2 empty para
     Selection.Delete Unit:=wdCharacter, Count:=1
     Selection.Delete Unit:=wdCharacter, Count:=1

    'Format all text
    Selection.WholeStory 'ctrl+A : select all text
    ' format font
    With Selection.Font
    .Name = "Times New Roman"
     .Size = 12
        .Bold = False
        .Italic = False
        .Underline = wdUnderlineNone
        .StrikeThrough = False
        .DoubleStrikeThrough = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Superscript = False
        .Subscript = False
        .Scaling = 100
        .Kerning = 0
    End With
    'format paragrgraph
    With Selection.ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphLeft
        .FirstLineIndent = CentimetersToPoints(0)
        .OutlineLevel = wdOutlineLevelBodyText
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .LineUnitBefore = 0
        .LineUnitAfter = 0
    End With

    'Delete all headers and footers (колонтитулы)
    Dim oSec As Section
    Dim oHead As HeaderFooter
    Dim oFoot As HeaderFooter

    For Each oSec In ActiveDocument.Sections
        For Each oHead In oSec.Headers
            If oHead.Exists Then oHead.Range.Delete
        Next oHead

        For Each oFoot In oSec.Footers
            If oFoot.Exists Then oFoot.Range.Delete
        Next oFoot
    Next oSec

  'войти в верхний колонтитул и удалить пустой параграф
  ' чтобы не показывал пустой параграф в уже удаленных колонтитулах
  ' Вообще это глюк, колонтитулов уже быть не должно (100% пустые быть должны)*
  '*(колонтитулы есть ВСЕГДА - даже во вновь созданном док-те
        If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.WholeStory
    Selection.Delete Unit:=wdCharacter, Count:=1
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument


    'find some text to be present for sure
    'and put it into Windows Clipboard
    'to clear it from bulky document content
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "Источник"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.Copy

    'Clear Undo history for THIS doc ONLY
    'to save free memory
    ActiveDocument.UndoClear

    'go home - top of doc
    Selection.HomeKey Unit:=wdStory

    ' Show user number of processed articles
    ' Offer user to save current processed doc
    Dim Msg, Style, Title, Help, Ctxt, Response, MyString
    Msg = articleCounter & " articles processed (total)." & vbCrLf & vbCrLf & "DO YOU WANT TO SAVE RESULTS?" & vbCrLf & vbCrLf & "macro version: 26_Sept_2019"    ' Define message.
    Style = vbOKCancel + vbInformation + vbDefaultButton1   ' Define buttons
    Title = "MACRO FINISHED AUTO-FORMATTING"    ' Define title
        ' Display message.
    Response = MsgBox(Msg, Style, Title)
    If Response = vbOK Then    ' User chose OK:
        'offer to save (user inputs path himself)
        defaultFileNameToSave = "Мониторинг СМИ_" & Date & "_macroProcessed"
        Application.FileDialog(msoFileDialogSaveAs).InitialFileName = defaultFileNameToSave
        Dim choice As Integer
        choice = Application.FileDialog(msoFileDialogSaveAs).Show
        If choice <> 0 Then
            FileName = Application.FileDialog(msoFileDialogSaveAs).SelectedItems(1)
            Application.FileDialog(msoFileDialogSaveAs).Execute
        End If
    Else    ' User chose Cancel:
       ' end of macro
    End If

    'Clear Clipboard (sometimes works, but not with Word 2002, not Word 2016)
    If Application.Version = "10.0" Then
    'it was possible to manipulate the Office Clipboard Toolbar in Word 2000, not later
    'Application.CutCopyMode = False ' no longer works in 2010

    'SECOND TRICK (only early word)
    'Dim oData As New DataObject 'object to use the clipboard
    'oData.SetText Text:=Empty 'Clear
    'oData.PutInClipboard 'take in the clipboard to empty it

    End If

    'prevents executing Error Handling block if no error occurred
    Exit Sub

'CATCHES ALL (any) ERRORS
AnyErrorHadler:
    ' Show UNCLASSIFIED Error Message
    Dim ErrorMsg, ErrorStyle, ErrorTitle
    ErrorMsg = "PROBABLY TEXT FORMAT CHANGED..." & vbCrLf & vbCrLf & "Contact developer (univ7@mail.ru) attaching failed file"     ' Define message.
    ErrorStyle = vbError   ' Define buttons
    ErrorTitle = "UNKNOWN ERROR WHILE PROCESSING!"    ' Define title
        ' Display message.
    Response = MsgBox(ErrorMsg, ErrorStyle, ErrorTitle)


End Sub