Advertisement
codeuniv

Jaroslav Macro 2019 - vSept_26_2019

Sep 26th, 2019
366
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VB.NET 19.05 KB | None | 0 0
  1. 'MACRO VERSION: vSept_26_2019 (UPDATED 26 Sept 2019)
  2. '1) SWITCH KEYBOARD/WINDOWS LANGUAGE TO RUSSIAN
  3. 'BEFORE COPYING (AND PASTING) THIS MACRO!!!
  4. '2). Word Object Model Changes (Word 2000 is VBA 6.0, Word 2010 is VBA 7.0, W2016=7.1)
  5. 'https://msdn.microsoft.com/en-us/library/office/bb149069(v=office.12).aspx
  6. Sub Digest_Formatter_MACRO_vSept_26_2019()
  7.  
  8. 'Enable error-handling routine
  9. On Error GoTo AnyErrorHadler
  10.  
  11.  
  12. 'Disable MRU Files list
  13. 'Application.RecentFiles.Maximum = 0
  14.  
  15.     'copy-paste all into new document
  16.     Selection.WholeStory
  17.     Selection.Copy
  18.     'clear selection in orig doc to save mem
  19.     Selection.HomeKey Unit:=wdStory 'go home (top)
  20.     Documents.Add DocumentType:=wdNewBlankDocument
  21.     Selection.PasteAndFormat (wdUseDestinationStylesRecovery)
  22.     'Clear Undo history for THIS doc ONLY
  23.     'b/c huge copied text chunk clogs memory
  24.     ActiveDocument.UndoClear
  25.    
  26.    
  27.     ' check MS Word version
  28.     ' CURRENTLY NOT USED
  29.     Select Case Application.Version
  30.      Case "16.0"
  31.        msWordVersion = "MS Word 2016 / Office 365 / Word 2019"
  32.     Case "15.0"
  33.        msWordVersion = "MS Word 2013"
  34.     Case "14.0"
  35.         msWordVersion = "MS Word 2010"
  36.     ' 13.0 is missing  (Microsoft skipped 13)
  37.     Case "12.0"
  38.         msWordVersion = "MS Word 2007"
  39.     Case "11.0"
  40.         msWordVersion = "MS Word 2003"
  41.     Case "10.0"
  42.         msWordVersion = "MS Word 2002 (aka  Word XP)"
  43.     Case "9.0"
  44.         msWordVersion = "MS Word 2000"
  45.     Case "8.0"
  46.         msWordVersion = "MS Word 97"
  47.     Case "7.0"
  48.         msWordVersion = "MS Word 95"
  49.     End Select
  50.    
  51.    
  52.     'Application.System.Version RETURNS:
  53.     ' "6.1" on Windows 7 and "6.2" on Windows 8
  54.     ' 10.0 on Windows 10
  55.                
  56. '*******************************************************************
  57. '********MAIN LOGIC START*******************************************
  58. '*******************************************************************
  59.    
  60.     'position cursor at HOME (doc start)
  61.     Selection.HomeKey Unit:=wdStory 'go home (top)
  62.    
  63.     'check if doc-to-process has TOC => check 3 markers:
  64.    
  65.     'check FirstMarkerPhrase
  66.     Selection.Find.ClearFormatting
  67.     With Selection.Find.Font
  68.         .Bold = True
  69.     End With
  70.     With Selection.Find
  71.         .Text = "Департамент корпоративных коммуникаций"
  72.         .Replacement.Text = ""
  73.         .Forward = True
  74.         .Wrap = wdFindContinue
  75.     End With
  76.    isHasFirstMarkerPhrase = Selection.Find.Execute
  77.    
  78.    '.Text = "Департаменткорпоративныхкоммуникаций" глюк
  79.    If isHasFirstMarkerPhrase = False Then
  80.        Selection.Find.ClearFormatting
  81.     With Selection.Find.Font
  82.         .Bold = True
  83.     End With
  84.     With Selection.Find
  85.         .Text = "Департаменткорпоративныхкоммуникаций"
  86.         .Replacement.Text = ""
  87.         .Forward = True
  88.         .Wrap = wdFindContinue
  89.     End With
  90.     isHasFirstMarkerPhrase = Selection.Find.Execute
  91.    End If
  92.    
  93.     'check SecondMarkerPhrase
  94.     Selection.HomeKey Unit:=wdStory 'go home (top)
  95.    
  96.     Selection.Find.ClearFormatting
  97.     With Selection.Find.Font
  98.         .Bold = True
  99.     End With
  100.     With Selection.Find
  101.         .Text = "МОНИТОРИНГ СМИ"
  102.         .Replacement.Text = ""
  103.         .Forward = True
  104.         .Wrap = wdFindContinue
  105.     End With
  106.    isHasSecondMarkerPhrase = Selection.Find.Execute
  107.    
  108.    '.Text = "МОНИТОРИНГСМИ" глюк
  109.    If isHasSecondMarkerPhrase = False Then
  110.     Selection.Find.ClearFormatting
  111.     With Selection.Find.Font
  112.         .Bold = True
  113.     End With
  114.     With Selection.Find
  115.         .Text = "МОНИТОРИНГСМИ"
  116.         .Replacement.Text = ""
  117.         .Forward = True
  118.         .Wrap = wdFindContinue
  119.     End With
  120.     isHasSecondMarkerPhrase = Selection.Find.Execute
  121.    End If
  122.    
  123.    
  124.    'check ThirdMarker - Column Separator
  125.     Selection.HomeKey Unit:=wdStory 'go home (top)
  126.    
  127.    Selection.Find.ClearFormatting
  128.     With Selection.Find
  129.         .Text = "^n"
  130.         .Replacement.Text = ""
  131.         .Forward = True
  132.         .Wrap = wdFindContinue
  133.         .Format = False
  134.     End With
  135.     isHasThirdMarker = Selection.Find.Execute
  136.    
  137.     'Remove TOC (if doc-to-process has any TOC)
  138.     If isHasFirstMarkerPhrase And isHasSecondMarkerPhrase And isHasThirdMarker Then
  139.     Selection.Find.ClearFormatting
  140.     With Selection.Find
  141.         .Text = "^n"
  142.         .Replacement.Text = ""
  143.         .Forward = True
  144.         .Wrap = wdFindContinue
  145.         .Format = False
  146.         .MatchCase = False
  147.         .MatchWholeWord = False
  148.         .MatchWildcards = False
  149.         .MatchSoundsLike = False
  150.         .MatchAllWordForms = False
  151.     End With
  152.     Selection.Find.Execute
  153.     Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
  154.     Selection.Delete Unit:=wdCharacter, Count:=1
  155.     Selection.Delete Unit:=wdCharacter, Count:=1
  156.     End If
  157.    
  158.    
  159.     ' BELOW PROCESSING LOGIC IS SAME FOR ANY DOCUMENT
  160.     '***************************************************************************
  161.    
  162.     Dim articleCounter As Integer
  163.    
  164.     'position cursor at HOME (doc start)
  165.     Selection.HomeKey Unit:=wdStory
  166.    
  167.     Dim isMoreMainHeadersPresent As Boolean 'defaults to FALSE
  168.    
  169.     'loop all MAIN HEADERs and
  170.     'process ONLY first article after each MAIN HEADER.
  171.     'Add no empty paragraphs as separators!
  172.     Do
  173. 'FIND MAIN HEADER
  174. '1.1. setup search
  175.         Selection.Find.ClearFormatting
  176.         With Selection.Find.Font
  177.             .Size = 20
  178.             .Bold = True
  179.             .Italic = True
  180.             .Underline = True
  181.             .Name = "Georgia"
  182.         End With
  183. '1.2. do search (for main header).
  184. 'search formatting only: FindText:=""
  185.         isMoreMainHeadersPresent = Selection.Find.Execute(FindText:="")
  186.        
  187.         'ГЛЮК: Word 2002 + docx plugin Font Size is 16, not 20 (as in higher Word) !!!
  188.         If isMoreMainHeadersPresent = False Then
  189.             Selection.Find.Font.Size = 16
  190.             isMoreMainHeadersPresent = Selection.Find.Execute(FindText:="")
  191.         End If
  192.        
  193.        
  194.         If isMoreMainHeadersPresent Then
  195.            
  196. 'DELETE FOUND MAIN HEADER
  197.             Selection.Delete
  198.            
  199. 'select line/para immediately after deleted MAIN HEADER
  200. '(including paragraph sign)
  201.             Selection.Expand wdParagraph
  202.             'Selection.EndKey Unit:=wdLine, Extend:=wdExtend 'Fails with multi-line para
  203.  
  204. 'PARSE/FIND: http://on-line-teaching.com/vba/lsn0107.html
  205.            
  206. 'parse article header
  207. '(save the line/para selected above to variable)
  208.             initialTitleStr = Selection.Range.Text
  209. 'construct wanted title string.
  210. '( _SERVICE$SOURCE#MARK_ will be replaced
  211. 'to "Заглавие:  " + 2 preceeding para marks later)
  212.             resultingTitleStr = "Заглавие: " + initialTitleStr
  213. 'Delete (previously selected) header line (paragraph)
  214.             Selection.Delete
  215.            
  216. 'select line/para immediately after deleted
  217. 'article header line (including paragraph sign)
  218.             Selection.Expand wdParagraph
  219.             'Selection.EndKey Unit:=wdLine, Extend:=wdExtend
  220.            
  221.             initiaDateAndSourceString = Selection.Range.Text
  222.            
  223.             Dim dateAndSourceStringLength As Integer
  224.            
  225.             dateAndSourceStringLength = Len(initiaDateAndSourceString)
  226.            
  227.             'some reasonable length enough to contain valid date and source
  228.             If (dateAndSourceStringLength > 8) Then
  229.            
  230.             'split string containing date and source into parts by comma separator
  231.             Dim dateAndSrcStrElements() As String
  232.             dateAndSrcStrElements = Split(initiaDateAndSourceString, ",")
  233.            
  234.             If (InStr(dateAndSrcStrElements(0), " ") <> 0) Then
  235.               'first comma-separated block contains space =>
  236.               'discard everything after space, and use everything before space as wanted date
  237.               Dim parts() As String
  238.               parts = Split(dateAndSrcStrElements(0), " ")
  239.               parsedDateWithoutTime = parts(0)
  240.             Else
  241.             'first comma-separated block is already wanted date
  242.               parsedDateWithoutTime = dateAndSrcStrElements(0)
  243.             End If
  244.            
  245.            
  246.             If (InStr(dateAndSrcStrElements(1), ":") <> 0) Then
  247.               'second comma-separated block is time
  248.               'discard this block completely
  249.               'TODO: MAYBE LATER THIS BLOCK WOULD HAVE NEEDED INFO - IF FORMAT LATER CHANGES
  250.               parsedSource = dateAndSrcStrElements(2)
  251.             Else
  252.             'second comma-separated block is already wanted source
  253.               parsedSource = dateAndSrcStrElements(1)
  254.             End If
  255.            
  256.            
  257.              If ((InStr(parsedSource, vbCrLf) = 0) And (InStr(parsedSource, vbCr) = 0) And (InStr(parsedSource, vbLf) = 0)) Then
  258.                 parsedSource = parsedSource + vbCrLf
  259.             End If
  260.                              
  261.            
  262.             resultingDateAndSourceText = "_SERVICE$SOURCE#MARK_" + parsedSource
  263.            
  264.             resultingDateAndSourceText = resultingDateAndSourceText + "Дата выпуска: " + parsedDateWithoutTime + vbCrLf
  265.            
  266.             Selection.Range.Text = resultingDateAndSourceText + resultingTitleStr
  267.            
  268.             articleCounter = articleCounter + 1
  269.            
  270.         End If
  271.        
  272.        End If  'If (dateAndSourceStringLength > 8) Then
  273.        
  274.     Loop While isMoreMainHeadersPresent
  275.     'Now loop Headers of Remaining Articles
  276.     'process all respective articles
  277.     'Add no empty paragraphs as separators!
  278.     Selection.HomeKey Unit:=wdStory 'GO HOME (top of file) FIRST TO SEARCH FROM BEGINNING
  279.    
  280.     Do
  281. 'FIND Article header
  282. '1.1. setup search
  283.         Selection.Find.ClearFormatting
  284.          With Selection.Find.ParagraphFormat
  285.         .SpaceBefore = 12
  286.     End With
  287. '1.2. do search (for regular article header).
  288. 'search formatting only: FindText:=""
  289.         isMoreArticleHeadersPresent = Selection.Find.Execute(FindText:="")
  290.        
  291.         If isMoreArticleHeadersPresent Then
  292.            
  293. 'parse article header
  294. '(save the line/para selected above to variable)
  295.             initialTitleStr = Selection.Range.Text
  296. 'construct wanted title string.
  297. '( _SERVICE$SOURCE#MARK_ will be replaced
  298. 'to "Заглавие:  " + 2 preceeding para marks later)
  299.             resultingTitleStr = "Заглавие: " + initialTitleStr
  300. 'Delete (previously selected) header line (paragraph)
  301.             Selection.Delete
  302.            
  303. 'select line/para immediately after deleted
  304. 'article header line (including paragraph sign)
  305.             Selection.Expand wdParagraph
  306.             'Selection.EndKey Unit:=wdLine, Extend:=wdExtend
  307.            
  308.             initiaDateAndSourceString = Selection.Range.Text
  309.            
  310.                       'split string containing date and source into parts by comma separator
  311.            
  312.             dateAndSrcStrElements = Split(initiaDateAndSourceString, ",")
  313.            
  314.             If (InStr(dateAndSrcStrElements(0), " ") <> 0) Then
  315.               'first comma-separated block contains space =>
  316.               'discard everything after space, and use everything before space as wanted date
  317.               parts = Split(dateAndSrcStrElements(0), " ")
  318.               parsedDateWithoutTime = parts(0)
  319.             Else
  320.             'first comma-separated block is already wanted date
  321.               parsedDateWithoutTime = dateAndSrcStrElements(0)
  322.             End If
  323.            
  324.            
  325.             If (InStr(dateAndSrcStrElements(1), ":") <> 0) Then
  326.               'second comma-separated block is time
  327.               'discard this block completely
  328.               'TODO: MAYBE LATER THIS BLOCK WOULD HAVE NEEDED INFO - IF FORMAT LATER CHANGES
  329.               parsedSource = dateAndSrcStrElements(2)
  330.             Else
  331.             'second comma-separated block is already wanted source
  332.               parsedSource = dateAndSrcStrElements(1)
  333.             End If
  334.            
  335.               If ((InStr(parsedSource, vbCrLf) = 0) And (InStr(parsedSource, vbCr) = 0) And (InStr(parsedSource, vbLf) = 0)) Then
  336.                 parsedSource = parsedSource + vbCrLf
  337.             End If
  338.            
  339.             resultingDateAndSourceText = "_SERVICE$SOURCE#MARK_" + parsedSource
  340.            
  341.             resultingDateAndSourceText = resultingDateAndSourceText + "Дата выпуска: " + parsedDateWithoutTime + vbCrLf
  342.            
  343.             Selection.Range.Text = resultingDateAndSourceText + resultingTitleStr
  344.            
  345.             articleCounter = articleCounter + 1
  346.            
  347.         End If
  348.     Loop While isMoreArticleHeadersPresent
  349.    
  350.    
  351.    
  352.     'Now Replace
  353.     '_SERVICE$SOURCE#MARK_
  354.     'to "Заглавие:  " + add 2 preceeding para marks)
  355.     Selection.HomeKey Unit:=wdStory  'GO HOME (top of file) - not neccesary, but just in case
  356.     'Replace
  357.         Selection.Find.ClearFormatting
  358.     Selection.Find.Replacement.ClearFormatting
  359.     With Selection.Find
  360.         .Text = "_SERVICE$SOURCE#MARK_"
  361.         .Replacement.Text = "^p^pИсточник:"
  362.         .Forward = True
  363.         .Wrap = wdFindContinue
  364.         .Format = False
  365.         .MatchCase = True
  366.     End With
  367.     Selection.Find.Execute Replace:=wdReplaceAll
  368.    
  369.    
  370.      Selection.HomeKey Unit:=wdStory 'go home - top of doc
  371.      'delete 2 empty para
  372.      Selection.Delete Unit:=wdCharacter, Count:=1
  373.      Selection.Delete Unit:=wdCharacter, Count:=1
  374.    
  375.     'Format all text
  376.     Selection.WholeStory 'ctrl+A : select all text
  377.     ' format font
  378.     With Selection.Font
  379.     .Name = "Times New Roman"
  380.      .Size = 12
  381.         .Bold = False
  382.         .Italic = False
  383.         .Underline = wdUnderlineNone
  384.         .StrikeThrough = False
  385.         .DoubleStrikeThrough = False
  386.         .Hidden = False
  387.         .SmallCaps = False
  388.         .AllCaps = False
  389.         .Color = wdColorAutomatic
  390.         .Superscript = False
  391.         .Subscript = False
  392.         .Scaling = 100
  393.         .Kerning = 0
  394.     End With
  395.     'format paragrgraph
  396.     With Selection.ParagraphFormat
  397.         .LeftIndent = CentimetersToPoints(0)
  398.         .RightIndent = CentimetersToPoints(0)
  399.         .SpaceBefore = 0
  400.         .SpaceBeforeAuto = False
  401.         .SpaceAfter = 0
  402.         .SpaceAfterAuto = False
  403.         .LineSpacingRule = wdLineSpaceSingle
  404.         .Alignment = wdAlignParagraphLeft
  405.         .FirstLineIndent = CentimetersToPoints(0)
  406.         .OutlineLevel = wdOutlineLevelBodyText
  407.         .CharacterUnitLeftIndent = 0
  408.         .CharacterUnitRightIndent = 0
  409.         .CharacterUnitFirstLineIndent = 0
  410.         .LineUnitBefore = 0
  411.         .LineUnitAfter = 0
  412.     End With
  413.  
  414.     'Delete all headers and footers (колонтитулы)
  415.     Dim oSec As Section
  416.     Dim oHead As HeaderFooter
  417.     Dim oFoot As HeaderFooter
  418.  
  419.     For Each oSec In ActiveDocument.Sections
  420.         For Each oHead In oSec.Headers
  421.             If oHead.Exists Then oHead.Range.Delete
  422.         Next oHead
  423.  
  424.         For Each oFoot In oSec.Footers
  425.             If oFoot.Exists Then oFoot.Range.Delete
  426.         Next oFoot
  427.     Next oSec
  428.    
  429.   'войти в верхний колонтитул и удалить пустой параграф
  430.   ' чтобы не показывал пустой параграф в уже удаленных колонтитулах
  431.   ' Вообще это глюк, колонтитулов уже быть не должно (100% пустые быть должны)*
  432.   '*(колонтитулы есть ВСЕГДА - даже во вновь созданном док-те
  433.         If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
  434.         ActiveWindow.Panes(2).Close
  435.     End If
  436.     If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
  437.         ActivePane.View.Type = wdOutlineView Then
  438.         ActiveWindow.ActivePane.View.Type = wdPrintView
  439.     End If
  440.     ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
  441.     Selection.WholeStory
  442.     Selection.Delete Unit:=wdCharacter, Count:=1
  443.     ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
  444.    
  445.    
  446.     'find some text to be present for sure
  447.     'and put it into Windows Clipboard
  448.     'to clear it from bulky document content
  449.     Selection.Find.ClearFormatting
  450.     With Selection.Find
  451.         .Text = "Источник"
  452.         .Replacement.Text = ""
  453.         .Forward = True
  454.         .Wrap = wdFindContinue
  455.         .Format = False
  456.         .MatchCase = False
  457.         .MatchWholeWord = False
  458.         .MatchWildcards = False
  459.         .MatchSoundsLike = False
  460.         .MatchAllWordForms = False
  461.     End With
  462.     Selection.Find.Execute
  463.     Selection.Copy
  464.    
  465.     'Clear Undo history for THIS doc ONLY
  466.     'to save free memory
  467.     ActiveDocument.UndoClear
  468.    
  469.     'go home - top of doc
  470.     Selection.HomeKey Unit:=wdStory
  471.    
  472.     ' Show user number of processed articles
  473.     ' Offer user to save current processed doc
  474.     Dim Msg, Style, Title, Help, Ctxt, Response, MyString
  475.     Msg = articleCounter & " articles processed (total)." & vbCrLf & vbCrLf & "DO YOU WANT TO SAVE RESULTS?" & vbCrLf & vbCrLf & "macro version: 26_Sept_2019"    ' Define message.
  476.     Style = vbOKCancel + vbInformation + vbDefaultButton1   ' Define buttons
  477.     Title = "MACRO FINISHED AUTO-FORMATTING"    ' Define title
  478.         ' Display message.
  479.     Response = MsgBox(Msg, Style, Title)
  480.     If Response = vbOK Then    ' User chose OK:
  481.         'offer to save (user inputs path himself)
  482.         defaultFileNameToSave = "Мониторинг СМИ_" & Date & "_macroProcessed"
  483.         Application.FileDialog(msoFileDialogSaveAs).InitialFileName = defaultFileNameToSave
  484.         Dim choice As Integer
  485.         choice = Application.FileDialog(msoFileDialogSaveAs).Show
  486.         If choice <> 0 Then
  487.             FileName = Application.FileDialog(msoFileDialogSaveAs).SelectedItems(1)
  488.             Application.FileDialog(msoFileDialogSaveAs).Execute
  489.         End If
  490.     Else    ' User chose Cancel:
  491.        ' end of macro
  492.     End If
  493.    
  494.     'Clear Clipboard (sometimes works, but not with Word 2002, not Word 2016)
  495.     If Application.Version = "10.0" Then
  496.     'it was possible to manipulate the Office Clipboard Toolbar in Word 2000, not later
  497.     'Application.CutCopyMode = False ' no longer works in 2010
  498.  
  499.     'SECOND TRICK (only early word)
  500.     'Dim oData As New DataObject 'object to use the clipboard
  501.     'oData.SetText Text:=Empty 'Clear
  502.     'oData.PutInClipboard 'take in the clipboard to empty it
  503.    
  504.     End If
  505.    
  506.     'prevents executing Error Handling block if no error occurred
  507.     Exit Sub
  508.    
  509. 'CATCHES ALL (any) ERRORS
  510. AnyErrorHadler:
  511.     ' Show UNCLASSIFIED Error Message
  512.     Dim ErrorMsg, ErrorStyle, ErrorTitle
  513.     ErrorMsg = "PROBABLY TEXT FORMAT CHANGED..." & vbCrLf & vbCrLf & "Contact developer (univ7@mail.ru) attaching failed file"     ' Define message.
  514.     ErrorStyle = vbError   ' Define buttons
  515.     ErrorTitle = "UNKNOWN ERROR WHILE PROCESSING!"    ' Define title
  516.         ' Display message.
  517.     Response = MsgBox(ErrorMsg, ErrorStyle, ErrorTitle)
  518.  
  519.    
  520. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement