Advertisement
codeuniv

Jaroslav Macro 2019

Feb 18th, 2019
250
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VBScript 12.64 KB | None | 0 0
  1. 'SWITCH KEYBOARD/WINDOWS LANGUAGE TO RUSSIAN
  2. 'BEFORE COPYING (AND PASTING) THIS MACRO!!!
  3. Sub SMI_Monitoring_Formatter_MACRO()
  4.  
  5.     'copy-paste all into new document
  6.    Selection.WholeStory
  7.     Selection.Copy
  8.     Documents.Add DocumentType:=wdNewBlankDocument
  9.     Selection.PasteAndFormat (wdUseDestinationStylesRecovery)
  10.    
  11.    
  12.     ' check MS Word version
  13.    ' CURRENTLY NOT USED
  14.    Select Case Application.Version
  15.      Case "16.0"
  16.        msWordVersion = "MS Word 2016 / Office 365 / Word 2019"
  17.     Case "15.0"
  18.        msWordVersion = "MS Word 2013"
  19.     Case "14.0"
  20.         msWordVersion = "MS Word 2010"
  21.     ' 13.0 is missing  (Microsoft skipped 13)
  22.    Case "12.0"
  23.         msWordVersion = "MS Word 2007"
  24.     Case "11.0"
  25.         msWordVersion = "MS Word 2003"
  26.     Case "10.0"
  27.         msWordVersion = "MS Word 2002 (aka  Word XP)"
  28.     Case "9.0"
  29.         msWordVersion = "MS Word 2000"
  30.     Case "8.0"
  31.         msWordVersion = "MS Word 97"
  32.     Case "7.0"
  33.         msWordVersion = "MS Word 95"
  34.     End Select
  35.    
  36.    
  37.     'Application.System.Version RETURNS:
  38.    ' "6.1" on Windows 7 and "6.2" on Windows 8
  39.    ' 10.0 on Windows 10
  40.              
  41. '*******************************************************************
  42. '********MAIN LOGIC START*******************************************
  43. '*******************************************************************
  44.    
  45.     'position cursor at HOME (doc start)
  46.    Selection.HomeKey Unit:=wdStory 'go home (top)
  47.    
  48.     'check if doc-to-process has TOC => check 3 markers:
  49.    
  50.     'check FirstMarkerPhrase
  51.    Selection.Find.ClearFormatting
  52.     With Selection.Find.Font
  53.         .Bold = True
  54.     End With
  55.     With Selection.Find
  56.         .Text = "Департамент корпоративных коммуникаций"
  57.         .Replacement.Text = ""
  58.         .Forward = True
  59.         .Wrap = wdFindContinue
  60.     End With
  61.    isHasFirstMarkerPhrase = Selection.Find.Execute
  62.    
  63.    
  64.     'check SecondMarkerPhrase
  65.    Selection.HomeKey Unit:=wdStory 'go home (top)
  66.    
  67.     Selection.Find.ClearFormatting
  68.     With Selection.Find.Font
  69.         .Bold = True
  70.     End With
  71.     With Selection.Find
  72.         .Text = "МОНИТОРИНГ СМИ"
  73.         .Replacement.Text = ""
  74.         .Forward = True
  75.         .Wrap = wdFindContinue
  76.     End With
  77.    isHasSecondMarkerPhrase = Selection.Find.Execute
  78.    
  79.    'check ThirdMarker - Column Separator
  80.    Selection.HomeKey Unit:=wdStory 'go home (top)
  81.    
  82.    Selection.Find.ClearFormatting
  83.     With Selection.Find
  84.         .Text = "^n"
  85.         .Replacement.Text = ""
  86.         .Forward = True
  87.         .Wrap = wdFindContinue
  88.         .Format = False
  89.     End With
  90.     isHasThirdMarker = Selection.Find.Execute
  91.    
  92.     'Remove TOC (if doc-to-process has any TOC)
  93.    If isHasFirstMarkerPhrase And isHasSecondMarkerPhrase And isHasThirdMarker Then
  94.     Selection.Find.ClearFormatting
  95.     With Selection.Find
  96.         .Text = "^n"
  97.         .Replacement.Text = ""
  98.         .Forward = True
  99.         .Wrap = wdFindContinue
  100.         .Format = False
  101.         .MatchCase = False
  102.         .MatchWholeWord = False
  103.         .MatchWildcards = False
  104.         .MatchSoundsLike = False
  105.         .MatchAllWordForms = False
  106.     End With
  107.     Selection.Find.Execute
  108.     Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
  109.     Selection.Delete Unit:=wdCharacter, Count:=1
  110.     Selection.Delete Unit:=wdCharacter, Count:=1
  111.     End If
  112.    
  113.    
  114.     ' BELOW PROCESSING LOGIC IS SAME FOR ANY DOCUMENT
  115.    '***************************************************************************
  116.    
  117.     Dim articleCounter As Integer
  118.    
  119.     'position cursor at HOME (doc start)
  120.    Selection.HomeKey Unit:=wdStory
  121.    
  122.     Dim isMoreMainHeadersPresent As Boolean 'defaults to FALSE
  123.    
  124.     'loop all MAIN HEADERs and
  125.    'process ONLY first article after each MAIN HEADER.
  126.    'Add no empty paragraphs as separators!
  127.    Do
  128. 'FIND MAIN HEADER
  129. '1.1. setup search
  130.        Selection.Find.ClearFormatting
  131.         With Selection.Find.Font
  132.             .Size = 20
  133.             .Bold = True
  134.             .Italic = True
  135.             .Underline = True
  136.             .Name = "Georgia"
  137.         End With
  138. '1.2. do search (for main header).
  139. 'search formatting only: FindText:=""
  140.        isMoreMainHeadersPresent = Selection.Find.Execute(FindText:="")
  141.        
  142.         If isMoreMainHeadersPresent Then
  143.            
  144. 'DELETE FOUND MAIN HEADER
  145.            Selection.Delete
  146.            
  147. 'select line/para immediately after deleted MAIN HEADER
  148. '(including paragraph sign)
  149.            Selection.Expand wdParagraph
  150.             'Selection.EndKey Unit:=wdLine, Extend:=wdExtend 'Fails with multi-line para
  151.  
  152. 'PARSE/FIND: http://on-line-teaching.com/vba/lsn0107.html
  153.            
  154. 'parse article header
  155. '(save the line/para selected above to variable)
  156.            initialTitleStr = Selection.Range.Text
  157. 'construct wanted title string.
  158. '( _SERVICE$SOURCE#MARK_ will be replaced
  159. 'to "Заглавие:  " + 2 preceeding para marks later)
  160.            resultingTitleStr = "Заглавие: " + initialTitleStr
  161. 'Delete (previously selected) header line (paragraph)
  162.            Selection.Delete
  163.            
  164. 'select line/para immediately after deleted
  165. 'article header line (including paragraph sign)
  166.            Selection.Expand wdParagraph
  167.             'Selection.EndKey Unit:=wdLine, Extend:=wdExtend
  168.            
  169.             initiaDateAndSourceString = Selection.Range.Text
  170.             parsedDate = Left(initiaDateAndSourceString, InStr(initiaDateAndSourceString, ",") - 1)
  171.             parsedSource = Mid(initiaDateAndSourceString, InStr(initiaDateAndSourceString, ",") + 1)
  172.            
  173.             resultingDateAndSourceText = "_SERVICE$SOURCE#MARK_" + parsedSource
  174.            
  175.             resultingDateAndSourceText = resultingDateAndSourceText + "Дата выпуска: " + parsedDate + vbCrLf
  176.            
  177.             Selection.Range.Text = resultingDateAndSourceText + resultingTitleStr
  178.            
  179.             articleCounter = articleCounter + 1
  180.            
  181.         End If
  182.     Loop While isMoreMainHeadersPresent
  183.    
  184.    
  185.    
  186.     'Now loop Headers of Remaining Articles
  187.    'process all respective articles
  188.    'Add no empty paragraphs as separators!
  189.    Selection.HomeKey Unit:=wdStory 'GO HOME (top of file) FIRST TO SEARCH FROM BEGINNING
  190.    
  191.     Do
  192. 'FIND Article header
  193. '1.1. setup search
  194.        Selection.Find.ClearFormatting
  195.          With Selection.Find.ParagraphFormat
  196.         .SpaceBefore = 12
  197.     End With
  198. '1.2. do search (for regular article header).
  199. 'search formatting only: FindText:=""
  200.        isMoreArticleHeadersPresent = Selection.Find.Execute(FindText:="")
  201.        
  202.         If isMoreArticleHeadersPresent Then
  203.            
  204. 'parse article header
  205. '(save the line/para selected above to variable)
  206.            initialTitleStr = Selection.Range.Text
  207. 'construct wanted title string.
  208. '( _SERVICE$SOURCE#MARK_ will be replaced
  209. 'to "Заглавие:  " + 2 preceeding para marks later)
  210.            resultingTitleStr = "Заглавие: " + initialTitleStr
  211. 'Delete (previously selected) header line (paragraph)
  212.            Selection.Delete
  213.            
  214. 'select line/para immediately after deleted
  215. 'article header line (including paragraph sign)
  216.            Selection.Expand wdParagraph
  217.             'Selection.EndKey Unit:=wdLine, Extend:=wdExtend
  218.            
  219.             initiaDateAndSourceString = Selection.Range.Text
  220.             parsedDate = Left(initiaDateAndSourceString, InStr(initiaDateAndSourceString, ",") - 1)
  221.             parsedSource = Mid(initiaDateAndSourceString, InStr(initiaDateAndSourceString, ",") + 1)
  222.            
  223.             resultingDateAndSourceText = "_SERVICE$SOURCE#MARK_" + parsedSource
  224.            
  225.             resultingDateAndSourceText = resultingDateAndSourceText + "Дата выпуска: " + parsedDate + vbCrLf
  226.            
  227.             Selection.Range.Text = resultingDateAndSourceText + resultingTitleStr
  228.            
  229.             articleCounter = articleCounter + 1
  230.            
  231.         End If
  232.     Loop While isMoreArticleHeadersPresent
  233.    
  234.    
  235.    
  236.     'Now Replace
  237.    '_SERVICE$SOURCE#MARK_
  238.    'to "Заглавие:  " + add 2 preceeding para marks)
  239.    Selection.HomeKey Unit:=wdStory  'GO HOME (top of file) - not neccesary, but just in case
  240.    'Replace
  241.        Selection.Find.ClearFormatting
  242.     Selection.Find.Replacement.ClearFormatting
  243.     With Selection.Find
  244.         .Text = "_SERVICE$SOURCE#MARK_"
  245.         .Replacement.Text = "^p^pИсточник:"
  246.         .Forward = True
  247.         .Wrap = wdFindContinue
  248.         .Format = False
  249.         .MatchCase = True
  250.     End With
  251.     Selection.Find.Execute Replace:=wdReplaceAll
  252.    
  253.    
  254.      Selection.HomeKey Unit:=wdStory 'go home - top of doc
  255.     'delete 2 empty para
  256.     Selection.Delete Unit:=wdCharacter, Count:=1
  257.      Selection.Delete Unit:=wdCharacter, Count:=1
  258.    
  259.     'Format all text
  260.    Selection.WholeStory 'ctrl+A : select all text
  261.    ' format font
  262.    With Selection.Font
  263.     .Name = "Times New Roman"
  264.      .Size = 12
  265.         .Bold = False
  266.         .Italic = False
  267.         .Underline = wdUnderlineNone
  268.         .StrikeThrough = False
  269.         .DoubleStrikeThrough = False
  270.         .Hidden = False
  271.         .SmallCaps = False
  272.         .AllCaps = False
  273.         .Color = wdColorAutomatic
  274.         .Superscript = False
  275.         .Subscript = False
  276.         .Scaling = 100
  277.         .Kerning = 0
  278.     End With
  279.     'format paragrgraph
  280.    With Selection.ParagraphFormat
  281.         .LeftIndent = CentimetersToPoints(0)
  282.         .RightIndent = CentimetersToPoints(0)
  283.         .SpaceBefore = 0
  284.         .SpaceBeforeAuto = False
  285.         .SpaceAfter = 0
  286.         .SpaceAfterAuto = False
  287.         .LineSpacingRule = wdLineSpaceSingle
  288.         .Alignment = wdAlignParagraphLeft
  289.         .FirstLineIndent = CentimetersToPoints(0)
  290.         .OutlineLevel = wdOutlineLevelBodyText
  291.         .CharacterUnitLeftIndent = 0
  292.         .CharacterUnitRightIndent = 0
  293.         .CharacterUnitFirstLineIndent = 0
  294.         .LineUnitBefore = 0
  295.         .LineUnitAfter = 0
  296.         .MirrorIndents = False
  297.     End With
  298.  
  299.     'Delete all headers and footers (колонтитулы)
  300.    Dim oSec As Section
  301.     Dim oHead As HeaderFooter
  302.     Dim oFoot As HeaderFooter
  303.  
  304.     For Each oSec In ActiveDocument.Sections
  305.         For Each oHead In oSec.Headers
  306.             If oHead.Exists Then oHead.Range.Delete
  307.         Next oHead
  308.  
  309.         For Each oFoot In oSec.Footers
  310.             If oFoot.Exists Then oFoot.Range.Delete
  311.         Next oFoot
  312.     Next oSec
  313.    
  314.   'войти в верхний колонтитул и удалить пустой параграф
  315.  ' чтобы не показывал пустой параграф в уже удаленных колонтитулах
  316.  ' Вообще это глюк, колонтитулов уже быть не должно (100% пустые быть должны)*
  317.  '*(колонтитулы есть ВСЕГДА - даже во вновь созданном док-те
  318.        If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
  319.         ActiveWindow.Panes(2).Close
  320.     End If
  321.     If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
  322.         ActivePane.View.Type = wdOutlineView Then
  323.         ActiveWindow.ActivePane.View.Type = wdPrintView
  324.     End If
  325.     ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
  326.     Selection.WholeStory
  327.     Selection.Delete Unit:=wdCharacter, Count:=1
  328.     ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
  329.    
  330.     'go home - top of doc
  331.    Selection.HomeKey Unit:=wdStory
  332.    
  333.     ' Show user number of processed articles
  334.    ' Offer user to save current processed doc
  335.    Dim Msg, Style, Title, Help, Ctxt, Response, MyString
  336.     Msg = articleCounter & " articles processed (total)." & vbCrLf & vbCrLf & "DO YOU WANT TO SAVE RESULTS?"     ' Define message.
  337.    Style = vbOKCancel + vbInformation + vbDefaultButton1   ' Define buttons
  338.    Title = "MACRO FINISHED AUTO-FORMATTING"    ' Define title
  339.        ' Display message.
  340.    Response = MsgBox(Msg, Style, Title)
  341.     If Response = vbOK Then    ' User chose OK:
  342.        'offer to save (user inputs path himself)
  343.        defaultFileNameToSave = "Мониторинг СМИ_" & Date & "_macroProcessed"
  344.         Application.FileDialog(msoFileDialogSaveAs).InitialFileName = defaultFileNameToSave
  345.         Dim choice As Integer
  346.         choice = Application.FileDialog(msoFileDialogSaveAs).Show
  347.         If choice <> 0 Then
  348.             FileName = Application.FileDialog(msoFileDialogSaveAs).SelectedItems(1)
  349.             Application.FileDialog(msoFileDialogSaveAs).Execute
  350.         End If
  351.     Else    ' User chose Cancel:
  352.       ' end of macro
  353.    End If
  354.    
  355. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement