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

守柔

            AutoType = .AutoShapeType
            Select Case AutoType
            Case msoShapeFlowchartAlternateProcess
                Set myShape = Me.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 0, 0, 0, 0)
            Case msoShapeFlowchartProcess
                Set myShape = Me.Shapes.AddShape(msoShapeFlowchartProcess, 0, 0, 0, 0)
            Case msoShapeMixed
                Set myShape = Me.Shapes.AddShape(msoShapeRectangle, 0, 0, 0, 0)
            Case msoShapeOval
                Set myShape = Me.Shapes.AddShape(msoShapeOval, 0, 0, 0, 0)
            Case Else
                Set myShape = Me.Shapes.AddShape(msoShapeRectangle, 0, 0, 0, 0)
            End Select
        Case msoLine
            Set myShape = Me.Shapes.AddLine(0, 0, 0, 0)
        Case msoTextBox
            Set myShape = Me.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 0, 0)
        End Select
        myShape.Name = "mySetShapeDefault"
        myShape.Apply
        Me.Save
    End With
    Exit Sub
ErrHandle:
    myMsg = "出错的过程名为:SetDrawingDefaults" & vbCrLf
    myMsg = myMsg & Now & "程序运行中发现错误:" & vbCrLf & "错误号:" & Err.Number & ",出错原因为:" & Err.Description
    Err.Clear
    Call HandleError
End Sub
'----------------------
Sub ShowDialogbywdDialogFormatDrawingObject()
'该对话框对画布中的图形将出错.
    Dim myDialog As Dialog, N As String
    On Error GoTo ErrHandle
    N = Word.CommandBars.ActionControl.Caption
    Set myDialog = Word.Dialogs(wdDialogFormatDrawingObject)
    With myDialog

守柔

        Select Case N
        Case "线条与颜色"
            .DefaultTab = 1200000
        Case "大小"
            .DefaultTab = 1200001
        Case "版式"
            .DefaultTab = 1200002
        Case "文本框"
            .DefaultTab = 1200005
        End Select
        .Show
    End With
    Exit Sub
ErrHandle:
    myMsg = "出错的过程名为:ShowDialogbywdDialogFormatDrawingObject" & vbCrLf
    myMsg = myMsg & Now & "程序运行中发现错误:" & vbCrLf & "错误号:" & Err.Number & ",出错原因为:" & Err.Description
    Err.Clear
    Call HandleError
End Sub
'----------------------
Sub HandleError()
    MsgBox myMsg, vbExclamation, msgTitle
    If MsgBox("是否需要发送错误报告?", vbQuestion + vbYesNo, msgTitle) = vbYes Then MailToAuthor
End Sub
'----------------------
Sub MailToAuthor()
'错误报告到作者
    Dim ShouRouMail1 As String, ShouRouMail2 As String
    On Error Resume Next
    ShouRouMail1 = "shourou@ExcelHome.net"
    ShouRouMail2 = "shourou_8@hotmail.com"
    ThisDocument.FollowHyperlink _
            "MailTo:" & ShouRouMail1 & "?Subject=Error Report" & "&CC=" & ShouRouMail2 & _
                      "&Body=" & msgTitle & " Find These Error:" & myMsg
End Sub
'----------------------

Option Explicit
Sub DelCanvas()
'删除画布保留图形,即将画布内图形原样移出,删除该画布

守柔

    Dim shpCanvas As Shape
    Dim shpCanvasShapes As CanvasShapes
    With Selection
        If .Type = wdSelectionShape Then    '如果所选的是图形的话
            If .ShapeRange(1).Type = msoCanvas Then    '如果所选图形是画布(画布中的某个图形)
                Set shpCanvas = .ShapeRange(1)
                Set shpCanvasShapes = shpCanvas.CanvasItems
                shpCanvasShapes.SelectAll
                .Cut
                .Delete
                .Paste
            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, 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
'----------------------

成品如下，请下载后以加载项形式加载。

WXiOv7v2.rar (11.48 KB, 下载次数: 59)

2006-10-26 06:42 上传

点击文件名下载附件
[求助]设置自选图形的默认效果及画布增删

yuyvtul

想当年，我多么需要这个功能其中的删除画布功能啊。呵呵。

菊石泽露

谢谢！

jyb2002

技术狂人：老大！！！[em06]

QBH

谢谢！学习了！

taigaoxiao

这个不是有整理好的吗？我上传下，有需要的直接下就好了

lgcmeli

一个画布，整成这样。惊为天人。