将word中的嵌入图片下移到邻近的单独一行

jurdy001

排版需要 若图片跟文字在同一段 则将图片下移到独自一段 并右对齐  效果如下：
原来：


弄成：

求助老师
图片很多  需要批量的vba代码

cuanju

需要上传文档。

jurdy001

cuanju 发表于 2020-3-13 19:13
需要上传文档。

不好意思  老师  没细看规则 抱歉
马上上传

cuanju

发不了代码，显示被拦截。
至于将图片下移，未做，请各位进行补充。
'=====================

sylun

可试试如下代码：

1. Sub test()
   
2.     Dim i As Integer
   
3.     Dim aShape As Shape
   
4.     Dim aInlineshape As InlineShape
   
5.    
   
6.     Application.ScreenUpdating = False
   
7.     Documents.Add ActiveDocument.FullName '在新文档处理，删除本行则在原文档处理
   
8.    
   
9.     '对图形对象仅调整其水平位置，不调整其垂直位置及其锁定的锚点位置
   
10.     For Each aShape In ActiveDocument.Shapes '针对浮动图形对象
    
11.         i = i + 1
    
12.         With aShape
    
13.             .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
    
14.             .Left = wdShapeRight
    
15.         End With
    
16.     Next
    
17.    
    
18.     For Each aInlineshape In ActiveDocument.InlineShapes  '针对嵌入式图形
    
19.         With aInlineshape.Range
    
20.             If .Paragraphs(1).Range.Characters.Count > 2 Then '不处理单独成行的嵌入式图形
    
21.                 i = i + 1
    
22.                 .Copy
    
23.                 .Paragraphs(1).Range.InsertParagraphAfter
    
24.                 .Move wdParagraph
    
25.                 .Paste
    
26.                 .ParagraphFormat.Alignment = wdAlignParagraphRight
    
27.                 aInlineshape.Delete
    
28.             End If
    
29.         End With
    
30.     Next
    
31.    
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "共处理了" & i & "个对象。"
    
34. End Sub

复制代码

jurdy001

sylun 发表于 2020-3-14 11:44
可试试如下代码：

老师 win 10  office365  运行有故障   估计是系统原因

琢磨了很久  加一句这个就行了
                    .Select
                    Selection.Copy

.Copy不稳定

sylun

平时基本上用2003版编写代码。可能是版本兼容性方面的问题。以下代码不用copy方法，并与cuanju的方法一样根据名称转换成嵌入式图形再处理

1. Sub test2()
   
2.     Dim i As Integer
   
3.     Dim aShape As Shape
   
4.     Dim shapenames() As String
   
5.     Dim aInlineshape As InlineShape
   
6.    
   
7.     On Error Resume Next
   
8.     Application.ScreenUpdating = False
   
9.     Documents.Add ActiveDocument.FullName '在新文档处理，删除本行则在原文档处理
   
10.    
    
11.     ReDim shapenames(ActiveDocument.Shapes.Count - 1)
    
12.     For Each aShape In ActiveDocument.Shapes '获取各浮动图形对象的名称
    
13.         shapenames(i) = aShape.Name
    
14.         i = i + 1
    
15.     Next
    
16.     For i = 0 To UBound(shapenames)  '根据上述名称将各浮动图形对象转换为嵌入式图形
    
17.         ActiveDocument.Shapes(shapenames(i)).ConvertToInlineShape
    
18.     Next
    
19.    
    
20.     For Each aInlineshape In ActiveDocument.InlineShapes '处理嵌入式图形
    
21.         With aInlineshape.Range
    
22.             If .Paragraphs(1).Range.Characters.Count > 2 Then '如果嵌入式图形不是单独一行
    
23.                 .Paragraphs(1).Range.InsertParagraphAfter
    
24.                 .Move wdParagraph
    
25.                 .FormattedText = aInlineshape.Range.FormattedText
    
26.                 aInlineshape.Delete
    
27.             Else '是单独一行，且其前一行（假设其前面均有段落）为空段落时则删除该空段落，不考虑手动换行符
    
28.                 If .Previous(wdParagraph).Characters.Count = 1 Then .Previous(wdParagraph).Delete
    
29.             End If
    
30.             .ParagraphFormat.Alignment = wdAlignParagraphRight
    
31.         End With
    
32.     Next
    
33.    
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "共处理了" & ActiveDocument.InlineShapes.Count & "个对象。"
    
36. End Sub

复制代码

，经简单测试，在win10 office2019也可通过：