用WORD宏自动裁剪排版长图片

m0_63882648 2022-01-08 14:37:39

Sub 长图打印()

'全文设置为单倍行矩，首行顶格=============================
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphJustify
.WidowControl = False
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
.CollapsedByDefault = False
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
Selection.HomeKey Unit:=wdStory

'设置页面横、竖方式===========================================
ymsz = 0
ymsz = InputBox("页面要设置成横向的吗？是-1/否-0", , 0)
If ymsz <> 1 Then ymsz = 0
Selection.PageSetup.Orientation = ymsz

'获取页面宽度(ymk)和高度(ymg)
ymk = ActiveDocument.PageSetup.PageWidth - ActiveDocument.PageSetup.LeftMargin - ActiveDocument.PageSetup.RightMargin
ymg = ActiveDocument.PageSetup.PageHeight - ActiveDocument.PageSetup.TopMargin - ActiveDocument.PageSetup.BottomMargin - 10

'是否需要分栏(fl)===============================================
fl = 1
fl = InputBox("需要分几栏显示？", , 1)
If fl > 10 Then fl = 10 '最多只允许分10栏
With ActiveDocument.PageSetup.TextColumns
.SetCount NumColumns:=fl
.EvenlySpaced = True
.LineBetween = True
If fl > 1 Then .Spacing = 1
End With
lk = Int(ActiveDocument.PageSetup.TextColumns.Width) '获取分栏设置后的栏宽

'插入需要裁剪打印的长图片========================================
tp = Dialogs(wdDialogInsertPicture).Show
If tp = -1 Then
Selection.HomeKey Unit:=wdStory
For Each s In ActiveDocument.Shapes
s.ConvertToInlineShape
Next s
Else
MsgBox "你没有插入任何图片，请重新开始 ^o^ "
Exit Sub
End If

'开始图片裁剪排版================================================
With ActiveDocument.InlineShapes(1)
.Width = lk
.ScaleHeight = .ScaleWidth '对插入的图片依据分栏的宽度进行等比例缩放
yk = .Width * 100 / .ScaleWidth
yg = .Height * 100 / .ScaleHeight '获取插入图片的原始真实宽度和高度
xg = .Height '获取缩放后的图片高度
fz = Int(xg / ymg) '根据图片的高度和页面高度判断需要裁剪的图片次数
bl = 100 / ActiveDocument.InlineShapes(1).ScaleHeight '图片裁剪数据和图片高度数据转换常量比率

If .Height > ymg Then '如果缩放后图片高度大于页面高度进行裁剪
.Select
Selection.Copy
For p = 1 To fz
Selection.Paste
Next p '根据需要裁剪的次数对插入的图片进行复制粘贴
For i = 0 To fz
With ActiveDocument.InlineShapes(i + 1)
cg = (xg - ymg) * 100 / .ScaleHeight - ymg * i * bl '计算每次需要从图片下面裁剪的长度
.PictureFormat.CropTop = ymg * i * bl
.PictureFormat.CropBottom = cg '对当前图片按照页面高度分别从上、下进行裁剪
End With
Next i
End If
End With
End Sub