SHARE
TWEET

Untitled

a guest Jan 22nd, 2020 71 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1.  
  2. Sub IWroteTheDamnBill()
  3. Application.Templates.LoadBuildingBlocks
  4.  Dim revs As Word.Revisions
  5.   Dim rev As Word.Revision, revOld As Word.Revision
  6.   Dim rngDoc As Word.Range
  7.   Dim rngRevNew As Word.Range, rngRevOld As Word.Range
  8.   Dim authMain As String, authNew As String, authOld As String
  9.   Dim bReject As Boolean
  10.  
  11.   bReject = False
  12.   Set rngDoc = ActiveDocument.Content
  13.   Set revs = rngDoc.Revisions
  14.   If revs.Count > 0 Then
  15.     authMain = revs(1).Author
  16.   Else 'No revisions so...
  17.     Exit Sub
  18.   End If
  19.  
  20.   For Each rev In revs
  21.     'rev.Range.Select  'for debugging, only
  22.     authNew = rev.Author
  23.     If rev.Type = wdRevisionInsert Or wdRevisionDelete Then
  24.         Set rngRevNew = rev.Range
  25.         'There's only something to compare if an Insertion
  26.         'or Deletion have been made prior to this
  27.         If Not rngRevOld Is Nothing Then
  28.             'The last revision was rejected, so we need to check
  29.             'whether the next revision (insertion for a deletion, for example)
  30.             'is adjacent and reject it, as well
  31.             If bReject Then
  32.                 If rngRevNew.Start - rngRevOld.End <= 1 And authNew <> authMain Then
  33.                     rev.Reject
  34.                 End If
  35.                 bReject = False 'reset in any case
  36.             End If
  37.  
  38.             'If the authors are the same there's no conflict
  39.             If authNew <> authOld Then
  40.                 'If the current revision is not the main author
  41.                 'and his revision is in the same range as the previous
  42.                 'this means his revision has replaced that
  43.                 'of the main author and must be rejected.
  44.                 If authNew <> authMain And rngRevNew.InRange(rngRevOld) Then
  45.                     rev.Reject
  46.                     bReject = True
  47.                 'If the previous revision is not the main author
  48.                 'and the new one is in the same range as the previous
  49.                 'this means that revision has replaced this one
  50.                 'of the main author and the previous must be rejected.
  51.                 ElseIf authOld <> authMain And rngRevOld.InRange(rngRevNew) Then
  52.                     revOld.Reject
  53.                     bReject = True
  54.                 End If
  55.             End If
  56.         End If
  57.         Set rngRevOld = rngRevNew
  58.         Set revOld = rev
  59.         authOld = authNew
  60.     End If
  61.  
  62.   Next
  63.  
  64. Dim chgAdd As Word.Revision
  65.  
  66. If ActiveDocument.Revisions.Count = 0 Then
  67.     MsgBox "There are no revisions in this document", vbOKOnly
  68. Else
  69.     ActiveDocument.TrackRevisions = False
  70.     For Each chgAdd In ActiveDocument.Revisions
  71.         If chgAdd.Type = wdRevisionDelete Then
  72.             chgAdd.Range.Font.StrikeThrough = True
  73.             chgAdd.Range.Font.Color = wdColorDarkBlue
  74.             chgAdd.Reject
  75.         ElseIf chgAdd.Type = wdRevisionInsert Then
  76.             chgAdd.Range.Font.Color = wdColorRed
  77.             chgAdd.Range.Font.Underline = wdUnderlineSingle
  78.             chgAdd.Range.Font.Bold = True
  79.             chgAdd.Accept
  80.         Else
  81.             MsgBox ("Unexpected Change Type Found"), vbOKOnly + vbCritical
  82.             chgAdd.Range.Select ' move insertion point
  83.         End If
  84.     Next chgAdd
  85. End If
  86.  
  87.  
  88. Dim objDoc As Document
  89.  
  90. Set objDoc = ActiveDocument
  91.  
  92.   With objDoc.Styles("Line Number").Font
  93.     .Name = "Times New Roman"
  94.     .Size = 11
  95.     .ColorIndex = wdBlack
  96.   End With
  97.  
  98.     If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
  99.         ActiveWindow.Panes(2).Close
  100.     End If
  101.     If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
  102.         ActivePane.View.Type = wdOutlineView Then
  103.         ActiveWindow.ActivePane.View.Type = wdPrintView
  104.     End If
  105.     ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
  106.     ActiveDocument.AttachedTemplate.BuildingBlockEntries("Page X of Y").Insert Where:=Selection.Range, _
  107.         RichText:=True
  108.     ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
  109.  
  110. With Selection.PageSetup
  111.         With .LineNumbering
  112.             .Active = True
  113.             .StartingNumber = 1
  114.             .CountBy = 1
  115.             .RestartMode = wdRestartContinuous
  116.             .DistanceFromText = wdAutoPosition
  117.         End With
  118.         .Orientation = wdOrientPortrait
  119.         .TopMargin = InchesToPoints(1)
  120.         .BottomMargin = InchesToPoints(1)
  121.         .LeftMargin = InchesToPoints(1)
  122.         .RightMargin = InchesToPoints(1)
  123.         .Gutter = InchesToPoints(0)
  124.         .HeaderDistance = InchesToPoints(0.5)
  125.         .FooterDistance = InchesToPoints(0.5)
  126.         .PageWidth = InchesToPoints(8.5)
  127.         .PageHeight = InchesToPoints(11)
  128.         .FirstPageTray = wdPrinterDefaultBin
  129.         .OtherPagesTray = wdPrinterDefaultBin
  130.         .SectionStart = wdSectionNewPage
  131.         .OddAndEvenPagesHeaderFooter = False
  132.         .DifferentFirstPageHeaderFooter = False
  133.         .VerticalAlignment = wdAlignVerticalTop
  134.         .SuppressEndnotes = False
  135.         .MirrorMargins = False
  136.         .TwoPagesOnOne = False
  137.         .BookFoldPrintingSheets = 1
  138.         .GutterPos = wdGutterPosLeft
  139.     End With
  140.    
  141.    
  142. With ActiveDocument.Styles("Footer")
  143.   .ParagraphFormat.Alignment = wdAlignParagraphCenter
  144. End With
  145.  
  146. Selection.WholeStory
  147. Selection.Font.Color = RGB(0, 0, 0)
  148. Selection.Font.Name = "Times New Roman"
  149. Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
  150.  
  151. End Sub
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top