Jaroslav Macro 2019

'SWITCH KEYBOARD/WINDOWS LANGUAGE TO RUSSIAN
'BEFORE COPYING (AND PASTING) THIS MACRO!!!
Sub SMI_Monitoring_Formatter_MACRO()

    'copy-paste all into new document
    Selection.WholeStory
    Selection.Copy
    Documents.Add DocumentType:=wdNewBlankDocument
    Selection.PasteAndFormat (wdUseDestinationStylesRecovery)


    ' 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


    '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

   '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:="")

        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
            parsedDate = Left(initiaDateAndSourceString, InStr(initiaDateAndSourceString, ",") - 1)
            parsedSource = Mid(initiaDateAndSourceString, InStr(initiaDateAndSourceString, ",") + 1)

            resultingDateAndSourceText = "_SERVICE$SOURCE#MARK_" + parsedSource

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

            Selection.Range.Text = resultingDateAndSourceText + resultingTitleStr

            articleCounter = articleCounter + 1

        End If
    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
            parsedDate = Left(initiaDateAndSourceString, InStr(initiaDateAndSourceString, ",") - 1)
            parsedSource = Mid(initiaDateAndSourceString, InStr(initiaDateAndSourceString, ",") + 1)

            resultingDateAndSourceText = "_SERVICE$SOURCE#MARK_" + parsedSource

            resultingDateAndSourceText = resultingDateAndSourceText + "Дата выпуска: " + parsedDate + 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
        .MirrorIndents = False
    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

    '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?"     ' 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

End Sub