|
|
楼主 |
发表于 2019-8-28 15:37
|
显示全部楼层
页面发生了变化，我有一段代码是自动获取了页面设置，但是好像只能提取竖版的，还只是两页另存为一个文件，单页另存的话就不行，你帮我看下。这段代码用在《不动产申请书》每两页另存为一个文档是可以的。《房屋信息调查表》是单页横版的，每页另存为一个文档。
Sub SplitEveryFivePagesAsDocuments()
Dim oSrcDoc As Document, oNewDoc As Document
Dim strSrcName As String, strNewName As String, strNewDot As String
Dim oRange As Range
Dim nIndex As Integer, nSubIndex As Integer, nTotalPages As Integer, nBound As Integer
Dim fso As Object
Dim sinLeft As Single, sinRight As Single, sinTop As Single, sinBottom As Single
Dim i As Integer, N As Integer
Dim pgOrientation As WdOrientation
Application.ScreenUpdating = False '关闭屏幕更新
Const nSteps = 2 ' 修改这里控制每隔几页分割一次
Set fso = CreateObject("Scripting.FileSystemObject")
Set oSrcDoc = ActiveDocument
Set oRange = oSrcDoc.Content
nTotalPages = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
oRange.Collapse wdCollapseStart
oRange.Select
For nIndex = 1 To nTotalPages Step nSteps
Set oNewDoc = Documents.Add
If nIndex + nSteps > nTotalPages Then
nBound = nTotalPages
Else
nBound = nIndex + nSteps - 1
End If
For nSubIndex = nIndex To nBound
oSrcDoc.Activate
oSrcDoc.Bookmarks("\page").Range.Copy
'读取页面设置
With oSrcDoc.Bookmarks("\page").Range.Sections(1).PageSetup
sinLeft = .LeftMargin '左页边距
sinRight = .RightMargin '右页边距
sinTop = .TopMargin '上边距
sinBottom = .BottomMargin '下边距
pgOrientation = .Orientation '纸张方向
End With
oSrcDoc.Windows(1).Activate
Application.Browser.Target = wdBrowsePage
Application.Browser.Next
oNewDoc.Activate
oNewDoc.Windows(1).Selection.Paste
oNewDoc.Background.Fill.Transparency = oSrcDoc.Background.Fill.Transparency
oNewDoc.Background.Fill.PresetTextured msoTexturePinkTissuePaper
With oNewDoc.PageSetup
.Orientation = pgOrientation
.LeftMargin = sinLeft
.RightMargin = sinRight
.TopMargin = sinTop
.BottomMargin = sinBottom
End With
Next nSubIndex
'删除空白段落
N = 0
temp = ActiveDocument.Paragraphs.Count
For i = temp To 1 Step -1
If Len(Trim(ActiveDocument.Paragraphs(i).Range)) = 1 Then
ActiveDocument.Paragraphs(i).Range.Delete
N = N + 1
Else
Exit For
End If
Next
strSrcName = oSrcDoc.FullName
strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
fso.GetBaseName(strSrcName) & "_" & (nIndex \ nSteps) & "." & fso.GetExtensionName(strSrcName))
oNewDoc.SaveAs strNewName
oNewDoc.Close False
Next nIndex
Set oNewDoc = Nothing
Set oRange = Nothing
Set oSrcDoc = Nothing
Set fso = Nothing
Application.ScreenUpdating = True '恢复屏幕更新
MsgBox "结束！"
End Sub
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-8-28 11:15
