[求助]设置自选图形的默认效果及画布增删

雨雪霏霏

谢谢老大问得如此具体！问题并不急，不要紧的，老大早上可不要起那么早——每天都是四点多起床，太累着老大了！

组合图形问题，说明如下：

每点“微”、“巨”、“连接符”等按钮作出的一个图形，都称为“小图形”；如果把一个画布里两个或两个以上的“小图形”通过“选中多个对象→全选→组合”组合起来，则把最终这个由“小图形”组成的图形称为“大图形”。

1、“删除画布”时，有以下两种情况：

①删除画布之前，画布里只有一个“小图形”。这种情况比较少。可称为特殊情况。要求在把画布删除之后，把这个“小图形”粘贴到文档中，设置其格式为“嵌入型”。

②删除画布之前，画布里只有一个“大图形”。这种情况非常普遍。可称为一般情况。要求在把画布删除之后，把这个“大图形”粘贴到文档中，设置其格式为“嵌入型”。

2、“增加画布”，其实是基于“删除画布”，也就是说昨天我把文档中所有画布都删除了，可今天发现几处图形格式还需要修改，或者是有必要对某个“大图形”内部的“小图形”进行对方方式的调整，那么，我就需要重新为这个“大图形”增加画布，便于在画布中“取消组合”之后，再进行各种对齐操作。

①对于“删除画布”中的“特殊情况”，因为画布里的“小图形”在插入文档后，不存在跟谁去对齐的问题，如果要调整它的大小，直接在文档中扩拉便可以，不需要用到画布——也就是说，“删除画布”中的“特殊情况”（仅仅是一个“小图形”）不必进行“增加画布”。

②对于“删除画布”中的“一般情况”，因为画布里的“大图形”在插入文档后，如果直接“取消组合”，再去修改某个分解出来的“小图形”，最终要重新“对齐”（小弟频繁使用到“对齐”中的“相对于画布”功能）、“组合”，极为困难，尤其是在非画布状态下根本无法使用“连接符”（对于稍严格的作图，“连接符”是极其重要的）。唯一的良方便是把这个“大图形”重新放回到画布里去“取消组合”，再进行各种操作，最终再把各个分解出来的“小图形”通过“选中多个对象→全选→组合”成为一个“大图形”，再运用“删除画布”宏，这样便完成了整个修改流程。——也就是说，“增加画布”其实只是针对“删除画布”中的“一般情况”，是针对“大图形”而言。

呵，小弟口齿不清，一个简单问题也要说上半天！要向老大的“简明扼要”多学习！

守柔

雨兄一段话，守柔半天忙，呵呵。

图形中的很多问题，以前都没有好好研究过，这次让雨兄逮个正着，好好过了把瘾。言归正传，处理起来，的确有很多意想不到的问题，且看代码，请雨兄测试：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2006-8-30 7:08:08
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0065^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Option Base 1 '声明数组下标为1
Sub DelCanvas()
    Dim shpCanvas As Shape, I As Integer, N As Integer
    Dim shpCanvasShapes As CanvasShapes, myShape As Shape
    Dim myVar() As Variant
    With Selection
        If .Type = wdSelectionShape Then    '如果所选的是图形的话
            If .ShapeRange(1).Type = msoCanvas Then    '如果所选图形是画布(画布中的某个图形)
                Set shpCanvas = .ShapeRange(1)
                Set shpCanvasShapes = shpCanvas.CanvasItems
                N = shpCanvasShapes.Count
                If N = 1 Then    ' 仅一个图形或者已组合的图形
                    Set myShape = shpCanvasShapes(1)
                Else
                    ReDim myVar(N) '声明一个动态数组
                    For I = 1 To N
                        myVar(I) = shpCanvasShapes(I).Name
                    Next
                    Set myShape = shpCanvasShapes.Range(myVar).Group
                End If
                myShape.Select
                .Cut
                .Delete
                .Paste
                .ShapeRange(1).WrapFormat.Type = wdWrapInline '嵌入式
            End If
        End If
    End With
End Sub
'----------------------

守柔

Sub AddCanvas()
    Dim shpCanvas As Shape, GW As Single, GH As Single
    Dim myShape As Shape, myLine As Shape
    With Selection
        If .Type = wdSelectionShape Then    '如果所选的是图形的话
            If .ShapeRange(1).Type = msoGroup Then   '如果所选图形是画布(画布中的某个图形)
                Set myShape = .ShapeRange(1)
                With myShape
                .WrapFormat.Type = wdWrapNone
                    GW = .Width
                    GH = .Height
                    .Select
                End With
                .Cut
                Set shpCanvas = ActiveDocument.Shapes.AddCanvas(Left:=0, Top:=0, Width:=GW + 10, Height:=GH + 10, Anchor:=.Paragraphs(1).Range)
                Set myLine = shpCanvas.CanvasItems.AddLine(0, 0, 0, 0)
                myLine.Select
                Selection.Delete
                .Paste
                shpCanvas.CanvasItems.SelectAll
                Application.Run "DrawUngroup" '取消组合
            End If
        End If
    End With
End Sub
'----------------------

雨雪霏霏

呵呵，世事多为“有钱能使鬼推磨”，小弟竟能以一介未庄土谷祠潦倒穷汉，“驱遣”武林盟主老大——化范仲淹句，则为“登斯楼也，此乐何极！”——“居EH之中，则烂柯忘返；处EH之外，则归心奔箭。是进必喜难禁，退必思不已。”

对于老大的“能耐”，小弟今番是有了深切体验了——老大此前确乎未对画布、图形有过深入的专题研究，可想不到种种小弟以为不可能之事，全部都被老大给一手“咔嚓”了！老大对于Word的触类旁通，对于VBA的全局把握，让小弟把眼瞪得月亮大小也仍然缓不过神来！

测试结果敬报如下：

1、删除画布。

完全合乎小弟理想！给老大敬上一片“金嗓子喉宝”！（呵呵，看了老大在《〈Word非常接触〉诞生日记》里的描述，才知道老大特别钟爱它！）

另外，还要特别感谢老大省去了小弟在删除画布之前进行手动“选中多个对象→全选→组合”的工作！老大是处处为小弟着想啊！

2、增加画布。

①感谢老大费力，竟然完美解决了小弟在49楼所提的关于“增加画布”两个难题！此后当省去多少汗水！

②同样要感谢老大省去了小弟在把“大图形”粘贴到画布之后需要手动进行的“取消组合”工作给减去了！——老大的编程之滴水不漏、量体裁衣之合脚合身，亦由此可见一斑！

③唯一需要解决的问题是——如何保证在增加了画布之后，这个画布是“嵌入型”的？

老大目前的代码运行结果，“增加画布”之后，画布为“浮于文字上方”，这就使得文档后边的内容也跑到了画布“背后”去了，粗看去，便是画布里的内容与文档的内容重叠在一起，无法进行辨别、编辑。

这就需要使这个新增的画布也是像原来的“大图形”一样是“嵌入型”的。

有两种情况需要先说明：

A、原来的“大图形”是“嵌入型”于一段文字的段首的，相当于一段文字的第一个文字，也就是说在这个“大图形”之后，还有很多其他文字（也有可能是其他的“嵌入型”“大图形”），最后才是一个段落标记。这样，新增了画布之后，这个画布也是要“嵌入型”于这个段落里的，跟这个段落里的其他文字、“大图形”组成一个段落。

B、原来的“大图形”是“嵌入型”于全段文字的，也就是说，这个“大图形”之后紧接着的就是段落标记，再没有其他文字，它单独为一段。这样，新增了画布之后，这个画布是“嵌入型”于整个段落的，亦即画布的右下角外沿便是段落标记。

A种情况不常见。B种情况极为普遍。老大若是觉得A种情况过于烦琐而不作考虑，小弟十分理解。

小弟在运行了“增加画布”宏之后，发现两个问题：

甲、后续段落全部消失。假设文档只有12345个段落（新建一个文档，每段都写上一个所在段落的数字，第一段是“1”，第二段是“大图形”，第三段是“3”……），“大图形”在第2段，现在运行“增加画布”宏，于是在文档中出现一个“浮于文字上方”的画布，画布之中是那些已经“取消组合”且全部都是处于选定状态的“小图形”，但这时除了有一个“1”段存在，后边的“3、4、5”三段全部没了。

乙、本段后续文字（假若“大图形”是在一段文字的段首，后边还有很多文字，接着才是段落标记）全部消失；后续的一个段落消失。——可以这样进行测试：对文档中的一个“大图形”循环应用“增加画布”“删除画布”两个宏，会发现，每一次循环，都会让“大图形”后边的内容消失了一段。

理想的效果，小弟觉得应该是这样——在一个文档中，对任意的“大图形”循环使用“增加画布”“删除画布”，最终修改完成的结果，都不会任何影响文档前后文格式（更不用说内容）——比如有一幢十层的楼房，我“偷梁换柱”，反复给第八层换肤换骨，但其他任何楼层没有感觉到丝毫动静。

小弟对于老大的“增加画布”中的数字进行改动，发现“Width:=GW + 10, Height:=GH + 10”如果都改为0值的话，会引起极大的麻烦，但改为“Width:=GW + 0.1, Height:=GH + 0.1”，不影响到宏的运行。——当然，这仅仅是发现，对于整个宏的操作并不产生多大的影响。

测试中，还出现了一回这样的对话框，小弟不知道究竟是何原因引起，也附图如下，请老大参考：

 

点上图的“帮助”，其内容如下：

内存溢出（错误 7）

 

需要更多的内存空间，或是遇到 64K 段边界限制。此错误有以下的原因和解决方法：

•     打开了太多的、文档或资源文件。

关闭不需要的应用程序、文档或资源文件。

•     模块或过程太大了。

将庞大的模块或过程分成几个。虽然这样不能节省内存空间，但可避免 64K 段边界限制。

•     在 Microsoft Windows 标准模式下执行。

按增强方式重新启动 Microsoft Windows 。

•     在 Microsoft Windows 增强方式下执行，但超出了虚拟内存的空间。

空出一些磁盘空间以增加虚拟内存，或至少确保有空馀的空间。

•     一些驻留程序在运行。

减少一些驻留程序。

•     设备驱动程序装载的太多。

减少一些不需要的设备驱动程序。

•     Public 变量超出了空间。

减少 Public 变量的数量。

详细信息，可选取有问题的项目，并按下 F1 （在Windows中）或HELP（在Macintosh中）键。

守柔

修改了一下代码,请雨兄再行测试.

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2006-8-30 20:59:51
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0066^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub AddCanvas()
    Dim shpCanvas As Shape, GW As Single, GH As Single
    Dim myShape As Shape, myLine As Shape, TF As Boolean
    Dim myRange As Range
    Application.ScreenUpdating = False
    With Selection
        If .Type = wdSelectionShape Then    '如果所选的是图形的话
            If .ShapeRange(1).Type = msoGroup Then   '如果所选图形是画布(画布中的某个图形)
                Set myShape = .ShapeRange(1)
                Set myRange = ActiveDocument.Range(.Paragraphs(1).Range.Start, .Paragraphs(1).Range.Start)
                '此句判断是段首或是段尾,若是段尾,则TF=TRUE
                If VBA.Asc(.Paragraphs(1).Range.Characters.First) <> 1 Then TF = True
                With myShape '修改图片格式
                    .WrapFormat.Type = wdWrapSquare
                    GW = .Width
                    GH = .Height
                    .Select
                End With
                .Cut
        

守柔

        '此处宽度和高度的增加量，视实际情况调整为某个固定值
                Set shpCanvas = ActiveDocument.Shapes.AddCanvas(Left:=0, Top:=0, Width:=GW + 1, Height:=GH + 1, Anchor:=myRange)
                Set myLine = shpCanvas.CanvasItems.AddLine(0, 0, 0, 0)
                myLine.Select
                Selection.Delete
                .Paste
                shpCanvas.CanvasItems.SelectAll
                Application.Run "DrawUngroup"    '取消组合
                shpCanvas.WrapFormat.Type = wdWrapInline
                If TF = True Then
                    shpCanvas.Select
                    .Cut
                    '定义一个RANGE对象,为段尾位置
                    Set myRange = ActiveDocument.Range(.Paragraphs(1).Range.End - 1, .Paragraphs(1).Range.End - 1)
                    myRange.Select
                    .Paste
                End If
            End If
        End If
    End With
    Application.ScreenUpdating = True
End Sub
'----------------------

关于内存溢出,目前我还是不能判断,需要结合上下文,建议调试时判断是哪行代码出了问题,通常数据类型导致的溢出可能性较大.

雨雪霏霏

“增加画布”宏测试圆满成功！谢谢老大完美解决小弟的问题！

再没发现什么溢出现象，无法告诉老大什么细节问题。谢谢老大对于溢出现象的思考！

一切到这里，似乎该结束了，老大付出的心血小弟看了惊心动魄，不能再往下说什么了！

两个小问题小声地问老大：

①增加画布、删除画布，都需要明显的等待（每个宏的运行，约等待两秒出现结果），老大是否可以加以改进？当然，这是小弟对此的“无理要求”，实际上它只是速度上的问题，而不是宏本身的“功能”问题。

②关于点按图形按钮后出现的“延迟”现象，只有在小弟上传的样件中出现，老大是否有空帮忙诊断一下？或者，在老大的代码中加进一些什么，也使得小弟的大型文档可以顺利跑动老大的图形模板？

不情之请，望老大“息怒”！呵呵！

守柔

刚才正在测试关于延迟（自动分页）的问题，从最初的思路上（两个方法）来说，完全失败。无论是设置自动分页为Flase，还是不创建画布，都无法阻止大文档中的自动分页“事件”，而且，一旦文档自动分页了，其值Word.Options.Pagination自动设置为True,好生纳闷。

关于你短信上所言，不急，我想，经过你再次的测试，可能还会有一些问题的，除了速度之外。

雨雪霏霏

谢谢老大的仔细诊断！看来，延迟的问题还要费老大许多宝贵的时间了！

经过多次测试，除了57楼的两个小问题，小弟没有别的问题可提了——呵呵，难题到了老大手里，鸡蛋里是再也挑不出骨头了。

说明：小弟上传的大型文档样件，其中有许多长文档排版的元素（样式、分节符、分页符、页面设置），夹杂着组织结构图、文本框，图形格式也不统一，有的是四周型的，有的是嵌入型的，还有的图形背后还有画布。另外，许多段落是固定行距的。

小弟有意再去这样模拟制作试验文档，无论如何也不能成功——也就是说，除了小弟上传的样件（或样件的母文档——即小弟目前在编辑使用的大型文档），其他任何文档都能流畅使用老大的图形模板。

此为小弟注册论坛以来所发的第200帖。就是“初级二”了，感慨在心而无所措辞！——用简朴的话来说吧：

感谢老大的各方面的帮助、栽培！（若以本主题帖而论，小弟虽然还摸不着VBA的门铃在哪儿，但已经因为老大在门里的倾力制造与娓娓描述，小弟心中有了VBA廓大的影像了！）此后有老大在前头阔步，小弟无畏人间风雨矣！

感谢孔兄的一路《驼铃》！小弟有幸与孔兄同生“家园”，造化荫护小弟至此！

感谢如意版主惊世之美照亮小弟的天空，虹霓之上，雾霭之中，飘渺如仙子，小弟感受到了别一种的美，此后行路，自有高格！谢谢如意版主在休闲吧这个极富创意的转帖：《冲出画片的图画》http://club.excelhome.net/viewthread.php?tid=105644&replyID=28147&skin=0！

老大是浑厚之美，孔兄是锐进之美，如意版主是月行云天之美！三位版主翼护之下，小弟在Word版块至今收获已是几火车，此后海上五月时光，可以沉稳而行矣！

守柔

2006-10-26日对此程序进行整理并附说明：

程序目的：

旨在提高Word文档中大量制图的效率。

假如说在Word程序原初状态下制作1000个图（1000个图都基于若干种图形格式——比如说此模板现提供的19种图形格式——当然，可按需扩展），需要12个小时的话，那么，使用此模板也制作同样的1000个图，只用1个小时便可完成。其中原因在于，使用此模板可以省去极多重复操作。

程序主要功能：

1.        可以在模板中自定义若干个自选图形格式和不同的尺寸，这些格式在绘制同一类形的图形中，成为默认自选图形格式，利用它，可以绘制出不同自定义默认格式的自选图形，并且可以通过一键通功能，方便地设置既定图形大小。

2.        可以通过【我的设置】/【恢复默认设置】功能，将自选图形格式恢复到Word初始状态的自选图形默认格式。

3.        对于任意新生成的自选图形，通过【CTRL+0】快捷键，程序自动判断当前图形类型和应用自定义的尺寸，可以自定义该命令，其宏名为【mySub】。

4.        可以直接进入自选图形格式对话框的相应选项卡。

5.        可以清除所选图形的画布而保留图形。

6.        可以为所选组合图形增加画布并移入默认段落位置。

7.        如果有更多的扩展，可以在myShape.dot中增加自选图形项目和设置。

[此贴子已经被作者于2006-10-26 6:27:50编辑过]