vba 选形状和线条的外观样式

ning84

从目前掌握的Excel 2007 没有模块代码。只能编程解决。



Sub SetShapeLineProperties()
   
    Dim ws As Worksheet
    Set ws = ActiveSheet
   
    Dim Shp As Shape
    Dim ShpRng As ShapeRange
        Set ShpRng = Application.ActiveWindow.Selection.ShapeRange
        Set Shp = Sheet3.Shapes(ShpRng.Name)
        With Shp
             Debug.Print .Line.ForeColor.RGB, .Line.BackColor.RGB, .Fill.BackColor.SchemeColor, .ShapeStyle
            '.Fill.BackColor.ObjectThemeColor = msoThemeColorAccent6
            '.Line.ForeColor.ObjectThemeColor = msoThemeColorFollowedHyperlink
            '.Line.BackColor.SchemeColor = 42
        End With
        
        ColorArr Shp, 0, 0, 27, 29
End Sub

Function ColorArr(Shp As Shape, lineForeRGB, lineBackRGB, fillForeRGB, fillBackRGB)
    With Shp.Shadow
         .ForeColor.SchemeColor = 17
         .OffsetX = 3
         .OffsetY = 3
         .Visible = msoCTrue
         .Transparency = 0.5
    End With
    Stop
    Dim Arr(29)
        Arr(0) = Array("黑色black", 0, 0, 0)
        Arr(1) = Array("红褐色maroon", 128, 0, 0)
        Arr(2) = Array("红色red", 255, 0, 0)
        Arr(3) = Array("橙色orange", 255, 128, 0)
        Arr(4) = Array("黄色yellow", 255, 255, 0)
        Arr(5) = Array("橄榄绿色olive", 128, 128, 0)
        Arr(6) = Array("酸橙色lime", 128, 255, 0)
        Arr(7) = Array("绿色green", 0, 255, 0)
        Arr(8) = Array("青色cyan", 0, 255, 255)
        Arr(9) = Array("蓝绿色teal", 0, 128, 128)
        Arr(10) = Array("蓝色blue", 0, 0, 255)
        Arr(11) = Array("海军蓝色navy", 0, 0, 128)
        Arr(12) = Array("紫色purple", 128, 0, 128)
        Arr(13) = Array("洋红色magenta", 255, 0, 255)
        Arr(14) = Array("白色white", 255, 255, 255)
        Arr(15) = Array("粉色pink", 255, 192, 203)
        Arr(16) = Array("绯红色crimson", 220, 20, 60)
        Arr(17) = Array("淡紫色lavender", 181, 126, 220)
        Arr(18) = Array("靛色indigo", 75, 0, 130)
        Arr(19) = Array("青绿色tarquoise", 64, 224, 208)
        Arr(20) = Array("黄绿色chartreuse", 127, 255, 0)
        Arr(21) = Array("浅黄色buff", 249, 233, 195)
        Arr(22) = Array("米黄色beige", 247, 238, 214)
        Arr(23) = Array("黄褐色tan", 210, 180, 140)
        Arr(24) = Array("卡其色khaki", 195, 176, 145)
        Arr(25) = Array("褐色brown", 150, 75, 0)
        Arr(26) = Array("铜色copper", 184, 115, 51)
        Arr(27) = Array("金色gold", 255, 215, 0)
        Arr(28) = Array("银色silver", 192, 192, 192)
        Arr(29) = Array("灰色grey/gray", 128, 128, 128)
        With Shp.Line
             .ForeColor.RGB = RGB(Arr(lineForeRGB)(1), Arr(lineForeRGB)(2), Arr(lineForeRGB)(3)) ' 设置线条颜色为红色
             .BackColor.RGB = RGB(Arr(lineBackRGB)(1), Arr(lineBackRGB)(2), Arr(lineBackRGB)(3))  ' 设置线条背景色为黄色
             .Weight = 2 ' 设置线条粗细为2磅
             .DashStyle = msoLineSolid ' 设置线条样式为实线

        End With
        With Shp.Fill
             .ForeColor.RGB = RGB(Arr(fillForeRGB)(1), Arr(fillForeRGB)(2), Arr(fillForeRGB)(3)) ' 设置线条颜色为红色
             .BackColor.RGB = RGB(Arr(fillBackRGB)(1), Arr(fillBackRGB)(2), Arr(fillBackRGB)(3))  ' 设置线条背景色为黄色
        End With
      

End Function




运行结果，不是目标需求 。也可能颜色学习不到位。



不是目标需求结果，预设的模块

ning84

TextEffectFormat.PresetTextEffect 属性

返回或设置指定艺术字的样式。MsoPresetTextEffect 类型，可读写。语法

表达式.PresetTextEffect

表达式   一个代表 TextEffectFormat 对象的变量。
说明

该属性的值与“艺术字库”对话框内的格式（按从左至右和从上至下的顺序编号）相对应。

MsoPresetTextEffect 可以是下列 MsoPresetTextEffect 常量之一。

msoTextEffect1

msoTextEffect10

msoTextEffect11

msoTextEffect12

msoTextEffect13

msoTextEffect14

msoTextEffect15

msoTextEffect16

msoTextEffect17

msoTextEffect18

msoTextEffect19

msoTextEffect2

msoTextEffect20

msoTextEffect21

msoTextEffect22

msoTextEffect23

msoTextEffect24

msoTextEffect25

msoTextEffect26

msoTextEffect27

msoTextEffect28

msoTextEffect29

msoTextEffect3

msoTextEffect30

msoTextEffect4

msoTextEffect5

msoTextEffect6

msoTextEffect7

msoTextEffect8

msoTextEffect9

msoTextEffectMixed

设置 PresetTextEffect 属性会自动设置指定形状的许多其他格式属性。

示例

本示例将 myDocument 中所有的艺术字样式设置为“艺术字库”对话框中列出的第一种样式。

Visual Basic for Applications

Set myDocument = Worksheets(1)For Each s In myDocument.Shapes    If s.Type = msoTextEffect Then        s.TextEffect.PresetTextEffect = msoTextEffect1    End IfNext

1. Sub DetermineShapeType()
   
2.     Dim shp As Shape
   
3.     Set shp = ActiveSheet.Shapes(1) '假设操作活动工作表中的第一个形状
   
4.    
   
5.     Select Case shp.Type
   
6.         Case msoAutoShape '自选图形
   
7.             MsgBox "形状是自选图形。"
   
8.         Case msoCallout '标注
   
9.             MsgBox "形状是标注。"
   
10.         Case msoChart '图表
    
11.             MsgBox "形状是图表。"
    
12.         Case msoComment '批注
    
13.             MsgBox "形状是批注。"
    
14.         Case msoFreeform '任意多边形
    
15.             MsgBox "形状是任意多边形。"
    
16.         Case msoGroup '组合形状
    
17.             MsgBox "形状是组合形状。"
    
18.         Case msoLine '线条
    
19.             MsgBox "形状是线条。"
    
20.         Case msoLinkedOLEObject '链接的 OLE 对象
    
21.             MsgBox "形状是链接的 OLE 对象。"
    
22.         Case msoLinkedPicture '链接的图片
    
23.             MsgBox "形状是链接的图片。"
    
24.         Case msoOLEControlObject 'OLE 控件对象
    
25.             MsgBox "形状是 OLE 控件对象。"
    
26.         Case msoPicture '图片
    
27.             MsgBox "形状是图片。"
    
28.         Case msoPlaceholder '占位符
    
29.             MsgBox "形状是占位符。"
    
30.         Case msoTextBox '文本框
    
31.             MsgBox "形状是文本框。"
    
32.         Case msoMedia '媒体对象
    
33.             MsgBox "形状是媒体对象。"
    
34.         Case msoTextEffect '艺术字
    
35.             MsgBox "形状是艺术字。"
    
36.         Case Else
    
37.             MsgBox "未知形状类型。"
    
38.     End Select
    
39. End Sub

复制代码

ning84

1. 
   
2. Sub ll()
   
3.     Dim Sld As Slide
   
4.         Set Sld = Application.ActivePresentation.Slides(19)
   
5.         Sld.Select
   
6.     Dim Shp As Shape, ShpRng As ShapeRange
   
7.         Set Shp = Sld.Shapes(4)
   
8.         Set ShpRng = Sld.Shapes.Range(Shp.Name)
   
9.         Debug.Print ShpRng.Name
   
10.         Shp4 ShpRng
    
11. End Sub
    
12. 
    
13. '''
    
14. Function Shp2(ShpRng As ShapeRange)
    
15.         
    
16.         With ShpRng
    
17.              Debug.Print .Left, .Top, .Width, .Height
    
18.              .Select
    
19.             
    
20.              .Left = 5
    
21.              .Top = 3
    
22.              .Width = 400
    
23.              .Height = 120
    
24.               With .TextEffect
    
25.                  
    
26.               End With
    
27.               
    
28.               With .TextFrame
    
29.                  .AutoSize = ppAutoSizeNone
    
30.                  .WordWrap = msoCTrue
    
31.                  .Orientation = msoTextOrientationHorizontal
    
32.                  .TextRange.ParagraphFormat.Alignment = ppAlignLeft
    
33.                  
    
34.               End With
    
35.               With .TextFrame2
    
36.               End With
    
37.               
    
38.               .Line.Visible = msoFalse
    
39.               .Fill.Visible = msoFalse
    
40.               
    
41.         End With
    
42.      
    
43.          
    
44. End Function
    
45. 
    
46. 
    
47. '''
    
48. Function Shp3(ShpRng As ShapeRange)
    
49.         
    
50.         With ShpRng
    
51.             
    
52.              'Debug.Print .Line.Visible, .Fill.Visible
    
53.              Debug.Print .Left, .Top, .Width, .Height
    
54.              .Select
    
55.             
    
56.              .Left = 230
    
57.              .Top = 473
    
58.              .Width = 170
    
59.              .Height = 70
    
60.              .Fill.Visible = msoFalse
    
61.              .Line.Visible = msoFalse
    
62.               With .TextEffect
    
63.                  
    
64.               End With
    
65.               
    
66.               With .TextFrame
    
67.                  .AutoSize = ppAutoSizeNone
    
68.                  .WordWrap = msoCTrue
    
69.                  .Orientation = msoTextOrientationHorizontal
    
70.                  .TextRange.ParagraphFormat.Alignment = ppAlignCenter
    
71.               End With
    
72.               With .TextFrame2
    
73.               End With
    
74.               .AutoShapeType = msoShapeHorizontalScroll
    
75.               .Line.Visible = msoCTrue
    
76.               .Fill.Visible = msoCTrue
    
77.               
    
78.         End With
    
79. 
    
80.          
    
81. End Function
    
82. 
    
83. 
    
84. Function Shp4(ShpRng As ShapeRange)
    
85.         
    
86.         With ShpRng
    
87.              Debug.Print .Left, .Top, .Width, .Height
    
88.              .Select
    
89.             
    
90.               .AutoShapeType = msoShapeRectangle
    
91.              .Left = 410
    
92.              .Top = 410
    
93.              .Width = 305
    
94.              .Height = 120
    
95.               With .TextEffect
    
96.                  
    
97.               End With
    
98.               
    
99.               With .TextFrame
    
100.                  .AutoSize = ppAutoSizeNone
     
101.                  .WordWrap = msoCTrue
     
102.                  .Orientation = msoTextOrientationHorizontal
     
103.                  .TextRange.ParagraphFormat.Alignment = ppAlignLeft
     
104.               End With
     
105.               With .TextFrame2
     
106.               End With
     
107.               .Fill.Visible = msoFalse
     
108.               .Line.Visible = msoFalse
     
109.               
     
110.         End With
     
111.      
     
112.          
     
113. End Function
     
114. 
     

复制代码