Yaroslav Macro (WORD 2002 + DOCX CONVERTER)

'ADJUSTED FOR WORD 2002 + DOCX CONVERTER (THEY GARBLE HEADERS FROM DOCX AND CHANGE HEADER FONT SIZE: 20->16!)
'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 SMI_Monitoring_Formatter_MACRO()

'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
            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
            Dim dateSplitLengthFromLeft As Long
            dateSplitLengthFromLeft = InStr(initiaDateAndSourceString, ",") - 1
            parsedDate = Left(initiaDateAndSourceString, dateSplitLengthFromLeft)
            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
    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?"     ' 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

End Sub