ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: 雨雪霏霏

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2006-10-22 07:03 | 显示全部楼层

以下内容由楼主总结归纳:

模板说明

一、设计目的:

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

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

二、注意事项:

①主要是在Word2003中使用,未对Word2000Word2007等其他版本进行兼容测试;

②主要是在Word2003中已经勾选了“工具→选项→常规→插入‘自选图形’时自动创建绘图画布”的情况下使用;当然,如果未勾选这一个选项,而是在无画布状态下作图(主要是作单个自选图形——没有将作出的几个图形进行高级的“对齐”“组合”的需求),将会更流畅(比在画布中作图多出了一项功能)。

③主要是在小文档(100页以下)中使用;大型文档(100页以上)中也可以使用,但作图速度会随文档的增大而减慢。

三、程序功能:

1、使用“自选图形”作图

其中分成两种情况:

①、不使用“绘图画布”情况下作图;

②、使用“绘图画布”情况下作图。

2、画布新功能

其中分成两种情况:

①、删除画布:如果某个(或某些)自选图形已经在一个画布之中,则为它(们)删去这个画布,不影响这个(或这组)自选图形的大小、位置。——主要是通过减少画布数量,以尽可能地降减Word文档大小。

②、增加画布:如果某个(或某些已经“组合”在一起的)自选图形未在画布之中,则为它(们)增加一个画布,这个画布的格式与原来这个自选图形的格式一样,即同样的为“嵌入型”或者其他类型、同样的是“首行缩进2字符”或未缩进——就这两点的“不变”,可称之为“位置不变”。新增的画布比原来的自选图形会大一些(量度可自行在VBA编码中调整,左右边距可为0厘米,但上下边距至少要大出0.01厘米)。

四、使用步骤:

1、从EH论坛下载老大的成品,解压。

2、自定义图形格式。

A、双击老大的“myShape.dot”文件,出现宏安全对话框,选择“禁用宏”,文件打开后显示的是一个未保存过的新文档,里边的内容为“自选图形模板说明表”;

B、将“效果示例”一列里的内容按自己的特殊需要进行重新设置,可以设置一两个图形,也可以设置几十乃至上百个图形(关于模板的后续“扩展”问题,还请老大详细说明,这里头涉及的量很大,编码也需要大批进行特殊定义)

C、将这个未保存过的新文档存储到与老大“myShape.dot”文件不同的位置,命名为“myShape.dot(是否可以命名成其他文件名,小弟未测试,恭请老大自行测试)

3、工具栏、快捷键设置。

①运行自定义设置后的“myShape.dot”,选择“启用宏”;

②看到出现在Word程序界面里的浮动工具栏后,点“工具→自定义”,对这浮动工具栏进行自己喜欢的风格改造(也可以不对这个浮动工具栏改造,而是自己另外新建一个工具栏,将这个浮动工具栏里的按钮复制到新建工具栏里);

③点“工具→自定义→键盘”,将宏里的“MySub”快捷键设置为自己喜欢的快捷键(如果未设置,则以后制图时是使用老大的预设置的快捷键“Ctrl+小键盘0

4、作图。

①无画布状态下作图,可以流畅使用“一键通”,可以在画好许多图后,回头再一一按快捷键;

②画布状态下作图,“一键通”功能限于最末一个图形,应当每画出一个图形便按快捷键。

6、画布增删。

①删除画布。

在画布状态下画好图后,觉得没有必要保留图后的画布,则请运行“DelCanvas”宏。

其结果,如果画布里原来只有一个图形(姑称之为“小图形”),那么直接删除画布;如果画布里原来有多个图形,那么运行此宏后,会自动将所有小图形“组合”成一个整体(姑称之为“大图形”),再插入画布在文档中的原位置。

②如果觉得要对某个大图形(小图形不必在画布里操作)重置于画布中进行高级编辑修改,请运行“AddCanvas”宏。

其结果是,画布将自动与图形的大小相匹配(如果手动在Word里添加画布,从来都只是新增一个固定大小的画布)。

7、随时自定义格式

作为小补充,在非画布状态下(画布中操作将出错),如果需要对某个“小图形”进行定项格式设置,比如说将其设置为“嵌入式”,那么可以使用浮动工具栏中的“对话框”里的按钮“一步到位”——找到“版式”按钮一点即可(当然,也可以为之设置快捷键)。

这就省得在频繁设置图形格式时来回切换对话框里的各个选项卡。

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

TA的精华主题

TA的得分主题

发表于 2006-10-22 07:04 | 显示全部楼层

分享全部代码:

'* +++++++++++++++++++++++++++++
'* Created By SHOUROU@ExcelHome 2006-10-26 6:02:31
'
仅测试于System: Windows NT Word: 11.0 Language: 2052
'
0087^The Code CopyIn [ThisDocument-ThisDocument]^'
'*
-----------------------------

Option Explicit
Dim F As Byte, myMsg As String
Const msgTitle As String = "ExcelHome_Word"

'Sub AutoExit()
'    Me.Save
'End Sub
Sub AutoExec()
    FormatSetUp (19)
End Sub
'----------------------
Sub FormatSetUp(F As Byte)
'
设置自选图形默认格式以及直接进入绘图状态

Word.Options.Pagination = False
    Dim myShape As Shape, shType As MsoShapeType
    Dim AutoType As MsoAutoShapeType
    Dim standardShape As Shape
    On Error GoTo ErrHandle
    If F = 19 Then
        Set standardShape = Me.Shapes("mySetShapeDefault")
    Else
        Set standardShape = Me.Shapes(F)
    End If
    standardShape.PickUp
    shType = standardShape.Type
    Select Case shType
    Case msoAutoShape
        AutoType = standardShape.AutoShapeType
        Select Case AutoType
        Case msoShapeFlowchartAlternateProcess
            Set myShape = ActiveDocument.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 0, 0, 0, 0)
            myShape.Apply
            myShape.SetShapesDefaultProperties
            myShape.Delete
            If F <> 19 Then Word.CommandBars("Drawing").Controls(3).Controls(5).Controls(2).Execute
        Case msoShapeFlowchartProcess
            Set myShape = ActiveDocument.Shapes.AddShape(msoShapeFlowchartProcess, 0, 0, 0, 0)
            myShape.Apply


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

TA的精华主题

TA的得分主题

发表于 2006-10-22 07:05 | 显示全部楼层

            myShape.SetShapesDefaultProperties
            myShape.Delete
            If F <> 19 Then Word.CommandBars("Drawing").Controls(3).Controls(5).Controls(1).Execute
        Case msoShapeOval
            Set myShape = ActiveDocument.Shapes.AddShape(msoShapeOval, 0, 0, 0, 0)
            myShape.Apply
            myShape.SetShapesDefaultProperties
            myShape.Delete
            If F <> 19 Then Word.CommandBars("Drawing").Controls(7).Execute
        Case msoShapeMixed
            Select Case F
            Case 11 To 14
                Set myShape = ActiveDocument.Shapes.AddConnector(msoConnectorCurve, 0, 0, 0, 0)
                myShape.Apply
                myShape.SetShapesDefaultProperties
                myShape.Delete
                If F <> 19 Then Word.CommandBars("Drawing").Controls(3).Controls(2).Controls(7).Execute
            Case 15, 16
                Set myShape = ActiveDocument.Shapes.AddConnector(msoConnectorElbow, 0, 0, 0, 0)
                myShape.Apply
                myShape.SetShapesDefaultProperties
                myShape.Delete
                If F <> 19 Then Word.CommandBars("Drawing").Controls(3).Controls(2).Controls(4).Execute
            End Select
        Case Else
            Set myShape = ActiveDocument.Shapes.AddShape(msoShapeRectangle, 0, 0, 0, 0)
            myShape.Apply
            myShape.SetShapesDefaultProperties
            myShape.Delete
        End Select
    Case msoLine
        Set myShape = ActiveDocument.Shapes.AddLine(0, 0, 0, 0)
    Case msoTextBox


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

TA的精华主题

TA的得分主题

发表于 2006-10-22 07:06 | 显示全部楼层

        Set myShape = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 0, 0)
    End Select
       Me.Saved = True
    Exit Sub
ErrHandle:
    myMsg = "
出错的过程名为
:FormatSetUp" & vbCrLf
    myMsg = myMsg & Now & "
程序运行中发现错误:" & vbCrLf & "错误号:" & Err.Number & ",出错原因为
:" & Err.Description
    Err.Clear
    Call HandleError
End Sub
'----------------------
Sub S1()
    F = 1
    Call FormatSetUp(1)
End Sub
'----------------------
Sub S2()
    F = 2
    Call FormatSetUp(2)
End Sub
'----------------------
Sub S3()
    F = 3
    Call FormatSetUp(3)
End Sub
'----------------------
Sub S4()
    F = 4
    Call FormatSetUp(4)
End Sub
'----------------------
Sub S5()
    F = 5
    Call FormatSetUp(5)
End Sub
'----------------------
Sub S6()
    F = 6
    Call FormatSetUp(6)
End Sub
'----------------------


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

TA的精华主题

TA的得分主题

发表于 2006-10-22 07:07 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

Sub S7()
    F = 7
    Call FormatSetUp(7)
End Sub
'----------------------
Sub S8()
    F = 8
    Call FormatSetUp(8)
End Sub
'----------------------
Sub S9()
    F = 9
    Call FormatSetUp(9)
End Sub
'----------------------
Sub S10()
    F = 10
    Call FormatSetUp(10)
End Sub
'----------------------
Sub S11()
    F = 11
    Call FormatSetUp(11)
End Sub
'----------------------
Sub S12()
    F = 12
    Call FormatSetUp(12)
End Sub
'----------------------
Sub S13()
    F = 13
    Call FormatSetUp(13)
End Sub
'----------------------
Sub S14()
    F = 14
    Call FormatSetUp(14)
End Sub
'----------------------
Sub S15()
    F = 15
    Call FormatSetUp(15)
End Sub


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

TA的精华主题

TA的得分主题

发表于 2006-10-22 07:08 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

Sub S7()
    F = 7
    Call FormatSetUp(7)
End Sub
'----------------------
Sub S8()
    F = 8
    Call FormatSetUp(8)
End Sub
'----------------------
Sub S9()
    F = 9
    Call FormatSetUp(9)
End Sub
'----------------------
Sub S10()
    F = 10
    Call FormatSetUp(10)
End Sub
'----------------------
Sub S11()
    F = 11
    Call FormatSetUp(11)
End Sub
'----------------------
Sub S12()
    F = 12
    Call FormatSetUp(12)
End Sub
'----------------------
Sub S13()
    F = 13
    Call FormatSetUp(13)
End Sub
'----------------------
Sub S14()
    F = 14
    Call FormatSetUp(14)
End Sub
'----------------------
Sub S15()
    F = 15
    Call FormatSetUp(15)
End Sub


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

TA的精华主题

TA的得分主题

发表于 2006-10-22 07:09 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

'----------------------
Sub S16()
    F = 16
    Call FormatSetUp(16)
End Sub
'----------------------
Sub S17()    '
红圆

    Call FormatSetUp(17)
End Sub
'----------------------
Sub S18()    '
恢复Word初始默认自选图形格式
    Call FormatSetUp(18)
End Sub
'----------------------
Sub S19()    '
调用"模板中的"储存的格式设置
    Call FormatSetUp(19)
End Sub
'----------------------
Sub mySet(W As Byte)
'
设置图形高度\文本框上下左右间距或者连接符箭头样式等
    Dim mySp As Shape
    On Error GoTo ErrHandle
    '
由于Word中不支持对于画布中选定图形的直接返回,此处的代码实际上有BUG
    With Selection
        If .Type = wdSelectionShape Then    '
如果所选的是图形的话

            If .ShapeRange(1).Type = msoCanvas Then    '
如果所选图形是画布(画布中的某个图形)
                Set mySp = .ShapeRange(1).CanvasItems(.ShapeRange(1).CanvasItems.Count)    '
定义为最后一个图形(总是新近创建/绘制的
)
            Else
                Set mySp = .ShapeRange(1)    '
否则为所选图形(非画布状态
)
            End If
        Else
            Exit Sub
        End If
    End With
    With mySp
        Select Case W
        Case 1 To 10
            Select Case W
            Case 1
                .Height = Word.CentimetersToPoints(0.65)
                With .TextFrame

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

TA的精华主题

TA的得分主题

发表于 2006-10-22 07:10 | 显示全部楼层

                    .MarginBottom = Word.CentimetersToPoints(0.03)
                    .MarginLeft = Word.CentimetersToPoints(0.05)
                    .MarginRight = Word.CentimetersToPoints(0.05)
                    .MarginTop = Word.CentimetersToPoints(0.03)
                End With
            Case 2
                .Height = Word.CentimetersToPoints(0.65)
                With .TextFrame
                    .MarginBottom = Word.CentimetersToPoints(0.03)
                    .MarginLeft = Word.CentimetersToPoints(0.15)
                    .MarginRight = Word.CentimetersToPoints(0.15)
                    .MarginTop = Word.CentimetersToPoints(0.03)
                End With
            Case 3
                .Height = Word.CentimetersToPoints(1.26)
                With .TextFrame
                    .MarginBottom = Word.CentimetersToPoints(0.03)
                    .MarginLeft = Word.CentimetersToPoints(0.05)
                    .MarginRight = Word.CentimetersToPoints(0.05)
                    .MarginTop = Word.CentimetersToPoints(0.03)
                End With
            Case 4
                .Height = Word.CentimetersToPoints(1.26)
                With .TextFrame
                    .MarginBottom = Word.CentimetersToPoints(0.03)
                    .MarginLeft = Word.CentimetersToPoints(0.15)
                    .MarginRight = Word.CentimetersToPoints(0.15)
                    .MarginTop = Word.CentimetersToPoints(0.03)
                End With
            Case 5
                .Height = Word.CentimetersToPoints(0.65)
                With .TextFrame
                    .MarginBottom = Word.CentimetersToPoints(0.03)
                    .MarginLeft = Word.CentimetersToPoints(0.05)
                    .MarginRight = Word.CentimetersToPoints(0.05)
                    .MarginTop = Word.CentimetersToPoints(0.03)
                End With
            Case 6
                .Height = Word.CentimetersToPoints(0.65)
                With .TextFrame
                    .MarginBottom = Word.CentimetersToPoints(0.03)
                    .MarginLeft = Word.CentimetersToPoints(0.15)
                    .MarginRight = Word.CentimetersToPoints(0.15)
                    .MarginTop = Word.CentimetersToPoints(0.03)

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

jxrZhwdZ.rar

23.37 KB, 下载次数: 12

VCPtUghU.rar

23.37 KB, 下载次数: 13

TA的精华主题

TA的得分主题

发表于 2006-10-26 06:29 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

                End With
            Case 7
                .Height = Word.CentimetersToPoints(0.7)
                With .TextFrame
                    .MarginBottom = Word.CentimetersToPoints(0.07)
                    .MarginLeft = Word.CentimetersToPoints(0.15)
                    .MarginRight = Word.CentimetersToPoints(0.15)
                    .MarginTop = Word.CentimetersToPoints(0.07)
                End With
            Case 8
                .Height = Word.CentimetersToPoints(1.3)
                With .TextFrame
                    .MarginBottom = Word.CentimetersToPoints(0.07)
                    .MarginLeft = Word.CentimetersToPoints(0.15)
                    .MarginRight = Word.CentimetersToPoints(0.15)
                    .MarginTop = Word.CentimetersToPoints(0.07)
                End With
            Case 9
                .Height = Word.CentimetersToPoints(0.75)
                With .TextFrame
                    .MarginBottom = Word.CentimetersToPoints(0.07)
                    .MarginLeft = Word.CentimetersToPoints(0.15)
                    .MarginRight = Word.CentimetersToPoints(0.15)
                    .MarginTop = Word.CentimetersToPoints(0.07)
                End With
            Case 10
                .Height = Word.CentimetersToPoints(1.35)
                With .TextFrame
                    .MarginBottom = Word.CentimetersToPoints(0.07)
                    .MarginLeft = Word.CentimetersToPoints(0.15)
                    .MarginRight = Word.CentimetersToPoints(0.15)
                    .MarginTop = Word.CentimetersToPoints(0.07)
                End With
            End Select
            .TextFrame.TextRange.Select
            Selection.Collapse
        Case 11 To 16
            Select Case W
            Case 11
            Case 12, 14, 15
                .Line.BeginArrowheadLength = msoArrowheadLengthMedium
                .Line.BeginArrowheadWidth = msoArrowheadWidthMedium

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

TA的精华主题

TA的得分主题

发表于 2006-10-26 06:36 | 显示全部楼层
                .Line.BeginArrowheadStyle = msoArrowheadOval
            Case 16
                .Line.BeginArrowheadLength = msoArrowheadShort
                .Line.BeginArrowheadWidth = msoArrowheadNarrow
                .Line.BeginArrowheadStyle = msoArrowheadDiamond
                .Line.EndArrowheadLength = msoArrowheadShort
                .Line.EndArrowheadWidth = msoArrowheadNarrow
                .Line.EndArrowheadStyle = msoArrowheadDiamond
            End Select
            F = 0
        End Select
    End With
    Exit Sub
ErrHandle:
    myMsg = "
出错的过程名为
:mySet" & vbCrLf
    myMsg = myMsg & Now & "
程序运行中发现错误:" & vbCrLf & "错误号:" & Err.Number & ",出错原因为
:" & Err.Description
    Err.Clear
    F = 0
    Call HandleError
End Sub
'----------------------
Sub MySub()
'
指定快捷键CTRL+0(数字小键盘)

'
根据不同的命令,进行不同的设置
    Call mySet(F)
    Me.Saved = True
End Sub
'----------------------
Sub SetDrawingDefaults()
'
修改Word命令,此代码用于右键中的设置自选图形默认效果
'
该代码基于将当前所选图形格式应于本文档(加载项)中并储存起来.然后指定图形格式
'
应用于本文档中,再设置为默认格式
    Dim myShape As Shape, shType As MsoShapeType
    Dim AutoType As MsoAutoShapeType
    On Error GoTo ErrHandle
    Me.Shapes("mySetShapeDefault").Delete
    With Selection.ShapeRange(1)
        shType = .Type
        .SetShapesDefaultProperties
        .PickUp
        Select Case shType
        Case msoAutoShape


您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-24 13:08 , Processed in 0.064526 second(s), 6 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表