|
Option Explicit
Sub TEST2()
Dim i&, Rng As Range, iStart&, iEnd&, n&, iPageNum&
Dim strFileName$, strPath$, strPreName$, Items As FileDialogSelectedItems
strPath = ThisDocument.Path & "\"
With Application.FileDialog(1)
With .Filters
.Clear
.Add "Excel Files", "*.doc?"
End With
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show Then Set Items = .SelectedItems Else Exit Sub
End With
strPreName = Right(Items(1), Len(Items(1)) - InStrRev(Items(1), "\"))
If strPreName = ThisDocument.Name Then Exit Sub
strPreName = Left(strPreName, InStrRev(strPreName, ".") - 1)
Application.ScreenUpdating = False
With Documents.Open(Items(1))
iPageNum = .Range.Information(wdNumberOfPagesInDocument)
For i = 1 To iPageNum Step 2
iStart = i
iEnd = IIf(i = iPageNum, iPageNum, i + 1)
Set Rng = .GoTo(wdGoToPage, Which:=wdGoToAbsolute, Count:=iStart)
Selection.GoTo wdGoToPage, Which:=wdGoToAbsolute, Count:=iEnd
With Rng
If iEnd = iPageNum Then
.SetRange .Start, Selection.Bookmarks("\page").End
Else
.SetRange .Start, Selection.Bookmarks("\page").End - 1
End If
.Select
.Copy
End With
n = n + 1
strFileName = strPath & strPreName & "-" & n
With Documents.Add
.Content.Paste
.SaveAs strFileName
.Close
End With
Next i
.Close False
End With
Application.ScreenUpdating = True
Beep
End Sub
|
|