组合图片缩放时文本框中文字对应缩放

yuyvtul

如图，文中有两个图形。
4AemooXk.rar (5.34 KB, 下载次数: 47)

2006-3-22 16:56 上传

点击文件名下载附件
[求助高手]守柔请看看

上面一个不带画布，若拖放放大缩小，则图中的文字大小不同时缩放。
下面一个带画布，若激活后点击缩放绘图按钮再缩放，图中的文字大小同时按比例合理缩放。
现要参考以上功能，用VBA实现如下目的(例如作一个“放大10％”的按钮)：
文中有很多不带画布的图形(且Word默认不用画布)，激活一个后，点击“放大10％”按钮，自动将图形装入画布中(在原地点)，并放大10％，然后取消画布。
即实现图形和其中的文字等比例放大。

[此贴子已经被作者于2006-7-13 20:32:26编辑过]

守柔

我最近实在时间有限。

抽空简单地做了一个，看一下，能否参考，而不用画布？

Sub Example()
Dim i As Shape, N As Byte, B As Shape
For Each i In Me.Shapes
If i.Type = msoGroup Then
For N = 1 To i.GroupItems.Count
Set B = i.GroupItems(N)
B.Left = 1.1 * B.Left
B.Width = 1.1 * B.Width
If B.TextFrame.HasText Then B.TextFrame.TextRange.Font.Size = 1.1 * B.TextFrame.TextRange.Font.Size
Next
End If
Next
End Sub

yuyvtul

谢谢守柔版主，代码运行后有两个问题：
①文本框的相对位置未变。
②运行速度较慢。
③文档中所有图片均放大

[此贴子已经被作者于2006-7-13 12:21:11编辑过]

yuyvtul

完美解决！感谢老大和鑫兄。
经鑫兄同意，将鑫兄写的代码公开共享：
Application.ScreenUpdating = False
  Dim q, w, b As Shape, er As CanvasShapes
  Set q = Selection.ShapeRange(1) '
  we = q.Type
 With ActiveDocument.Shapes
    If q.Type = msoGroup Then
     q.Select
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.ScaleHeight 1.2, False '
    Selection.ShapeRange.ScaleWidth 1.2, False '
    For w = 1 To q.GroupItems.Count
    Set b = q.GroupItems(w)
    If b.Type = msoTextBox Then
        b.TextFrame.TextRange.Font.Size = 1.2 * b.TextFrame.TextRange.Font.Size
        b.TextFrame.TextRange.ParagraphFormat.LineSpacingRule = wdLineSpaceAtLeast
        b.TextFrame.TextRange.ParagraphFormat.LineSpacing = 8

'本处可根据情况作调整
    End If
   Next
  End If
 End With
Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2006-7-13 12:31:44编辑过]