Sub ύXɒu()

    Dim originalPath As String
    Dim originalName As String
    Dim newFullPath As String
    
    With ActiveDocument
        originalPath = .Path
        originalName = .Name
        
        If originalPath = "" Then
            MsgBox "͂̕܂ۑĂ܂B" & vbCrLf & _
                   "ɖOtĕۑĂsĂB", vbExclamation
            Exit Sub
        End If
    End With
    
    ' Vt@Citj
    newFullPath = originalPath & "\" & "t" & originalName
    
    ' ====================
    ' 1. ύXɒu
    ' ====================
    Dim myRev As Revision
    Dim rng As Range
    Dim doc As Document
    
    Set doc = ActiveDocument
    
    ' ύX̋L^It
    doc.TrackRevisions = False
    
    For Each myRev In doc.Revisions
        
        If myRev.Type = wdRevisionDelete Then
            
            Set rng = myRev.Range.Duplicate   ' IWiێ
            
            ' ----- O1̊giE`FbNtj -----
            With rng
                ' O1gi擪łȂ΁j
                If .Start > 0 Then
                    .MoveStart unit:=wdCharacter, Count:=-1
                End If
                
                ' 1giłȂ΁j
                If .End < doc.Content.End - 1 Then
                    .MoveEnd unit:=wdCharacter, Count:=1
                End If
                
                ' 
                .Font.Underline = wdUnderlineSingle
                
                ' ύXm
                .Revisions.AcceptAll
            End With
            
        ElseIf myRev.Type = wdRevisionInsert Then
            ' }͂̂܂܉ێ
            With myRev.Range
                .Font.Underline = wdUnderlineSingle
                .Revisions.AcceptAll
            End With
            
        Else
            ' ̑̕ύX͏̂
            myRev.Accept
        End If
        
    Next myRev
    
    Set myRev = Nothing
    Set rng = Nothing
    Set doc = Nothing
    ' ====================
    ' 2. ۑiWord 2003Ήj
    ' ====================
    On Error GoTo SaveError
    
    ActiveDocument.SaveAs FileName:=newFullPath, _
                         FileFormat:=wdFormatDocument  ' Word 2003p
    
    MsgBox "I" & vbCrLf & _
           "ύXɒu܂B" & vbCrLf & _
           "ۑt@C: " & newFullPath, vbInformation, ""
    
    Exit Sub

SaveError:
    MsgBox "ۑɎs܂B" & vbCrLf & vbCrLf & _
           "G[ԍ: " & Err.Number & vbCrLf & _
           "ڍ: " & Err.Description & vbCrLf & vbCrLf & _
           "ۑpX: " & newFullPath, vbCritical

End Sub
