穷尽指定 AutoShape 对象的形状类型

ning84

图形－Shapes-ExcelHome  https://www.excelhome.net/87.html

1. Sub del1()
   
2.     Dim Arr
   
3.     Dim oLeft, oTop, oWidth, oHeight, mLeft
   
4.     Dim Shp As Shape
   
5.     Dim TxtFrm As TextFrame
   
6.     Dim TxtFrm2 As TextFrame2
   
7.     Dim ArrMsoAutoShapeType, ArrMso2007
   
8.     Dim ArrMsoThemeColorSchemeIndex
   
9. 
   
10.          ArrMsoAutoShapeType = Array(149, 150, 94, 95, 96, 91, 92, 147, 148, 93, 129, 131, 125, 134, 132, 130, 127, 126, 128, 136, 133, 135, 25, 137, 41, 44, 15, 20, 13, 182, 181, 180, 52, 161, 60, 179, 108, 162, 169, 11, 14, 48, 100, 46, 45, 47, 99, 144, 141, 4, 146, 18, 27, 26, 104, 36, 56, 98, 89, 90, 62, 75, 79, 73, 64, 63, 84, 87, 88, 67, 81, 66, 86, 71, 72, 82, 68, 139, 74, 78, 65, 70, 61, 76, 85, 80, 83, 77, 69, 16, 158, 174, 172, 173, 159, 21, 145, 10, 102, 7, 34, 54, 31, 29, 176, 37, 57, 177, 140, 40, 43, 22, 109, 113, 121, 117, 110, 114, 122, 118, 111, 115, 123, 119, 112, 116, 124, 120, 183, 166, 167, 164, 165, 168, 163, -2, 24, 143, 19, 50, 138, 6, 9, 107, 2, 51, 142, 175, 28, 171, 39, 59, 1, 105, 12, 33, 53, 32, 30, 8, 151, 157, 152, 5, 106, 17, 155, 157, 156, 154, 170, 49, 23, 178, 160, 3, 35, 55, 38, 58, 97, 42, 101, 103)
    
11.          Debug.Print UBound(ArrMsoAutoShapeType)
    
12.          ''
    
13.          ArrMso2007 = Array(94, 95, 96, 91, 92, 93, 129, 131, 125, 134, 132, 130, 127, 126, 128, 136, 133, 135, 25, 137, 41, 44, 15, 20, 13, 52, 60, 108, 11, 14, 48, 100, 46, 45, 47, 99, 4, 18, 27, 26, 104, 36, 56, 98, 89, 90, 62, 75, 79, 73, 64, 63, 84, 87, 88, 67, 81, 66, 86, 71, 72, 82, 68, 74, 78, 65, 70, 61, 76, 85, 80, 83, 77, 69, 16, 21, 10, 102, 7, 34, 54, 31, 29, 37, 57, 40, 43, 22, 109, 113, 121, 117, 110, 114, 122, 118, 111, 115, 123, 119, 112, 116, 124, 120, -2, 24, 19, 50, 138, 6, 9, 107, 2, 51, 28, 39, 59, 1, 105, 12, 33, 53, 32, 30, 8, 5, 106, 17, 49, 23, 3, 35, 55, 38, 58, 97, 42, 101, 103)
    
14.          Arr = Array(94, 95, 96, 91, 92, 93, 129, 131, 125, 134, 132, 130, 127, 126, 128, 136, 133, 135, 25, 137, 41, 44, 15, 20, 13, 52, 60, 108, 11, 14, 48, 100, 46, 45, 47, 99, 4, 18, 27, 26, 104, 36, 56, 98, 89, 90, 62, 75, 79, 73, 64, 63, 84, 87, 88, 67, 81, 66, 86, 71, 72, 82, 68, 74, 78, 65, 70, 61, 76, 85, 80, 83, 77, 69, 16, 21, 10, 102, 7, 34, 54, 31, 29, 37, 57, 40, 43, 22, 109, 113, 121, 117, 110, 114, 122, 118, 111, 115, 123, 119, 112, 116, 124, 120, -2, 24, 19, 50, 138, 6, 9, 107, 2, 51, 28, 39, 59, 1, 105, 12, 33, 53, 32, 30, 8, 5, 106, 17, 49, 23, 3, 35, 55, 38, 58, 97, 42, 101, 103)
    
15.          ''
    
16.          ArrMsoThemeColorSchemeIndex = Array(5, 6, 7, 8, 9, 10, 1, 3, 12, 11, 2, 4)
    
17.          ''
    
18.          For Each Shp In Sheet3.Shapes
    
19.                Shp.Delete
    
20.          Next Shp
    
21.          
    
22.          With Sheet3.Shapes
    
23.               oLeft = 5
    
24.               oTop = 5
    
25.               oWidth = 300
    
26.               oHeight = 30
    
27.               For ii = 0 To UBound(Arr)
    
28.                    Set Shp = .AddShape(Arr(ii), oLeft, oTop, oWidth, oHeight)
    
29.                    Set TxtFrm2 = Shp.TextFrame2
    
30.                    oLeft = mLeft
    
31.                    With TxtFrm2
    
32.                           .TextRange.Text = Shp.Name & oLeft & " x " & oTop & "x" & oWidth & " x " & oHeight
    
33.                           .AutoSize = msoAutoSizeShapeToFitText
    
34.                    End With
    
35.                    ''
    
36.                    oLeft = oLeft + oWidth + 50
    
37.                    Set Shp = .AddShape(Arr(ii), oLeft, oTop, oWidth + 50, oHeight)
    
38.                    Set TxtFrm = Shp.TextFrame
    
39.                    With TxtFrm
    
40.                           .Characters.Text = Shp.Name & oLeft & " x " & oTop & " x " & oWidth + 50 & " x " & oHeight
    
41.                           .AutoSize = True
    
42.                    End With
    
43.                    oTop = oTop + oHeight + 40
    
44.                    oLeft = mLeft
    
45.               Next ii
    
46.          End With
    
47. End Sub

复制代码

MsoAutoShapeType 枚举 (Office) | Microsoft Learn  https://learn.microsoft.com/zh-c ... ce.msoautoshapetype

眉毛都有数根白眉毛，头发基本全白的老汉，近期有点开窍。能编制有点难度的小程序。
小程序也就30多行代码。关键语句2条，Set Shp = .AddShape(Arr(ii), oLeft, oTop, oWidth, oHeight)，  Set TxtFrm2 = Shp.TextFrame2
数据源简化为数组，简化编程工作量。

ning84

184个MsoAutoShapeType 与12个MsoThemeColorSchemeIndex 枚举 组合为题。与各位网友共同穷尽形状和颜色的组合。

*****************
填充、渐变和效果概述填充是形状的内部颜色。在更改形状的填充颜色时，还可以向填充添加纹理、图片或渐变。渐变是颜色和底纹的逐渐过渡，通常是从一种颜色过渡到另一种颜色，或者从一种底纹过渡到同一颜色的另一种底纹。

更改形状的填充颜色只影响形状的内部或正面。如果您添加另一种效果（如阴影）并且希望为该效果应用另一种颜色，则必须单独更改阴影的颜色。
三维效果可增加形状的深度。您可以向形状添加内置的三维效果组合，也可以添加单个效果。



WdThemeColorIndex 枚举 (Microsoft.Office.Interop.Word) | Microsoft Learn  https://learn.microsoft.com/zh-c ... index?view=word-pia

msoThemeAccent1	5	指定配色方案“强调文字颜色 1”。
msoThemeAccent2	6	指定配色方案“强调文字颜色 2”。
msoThemeAccent3	7	指定配色方案“强调文字颜色 3”。
msoThemeAccent4	8	指定配色方案“强调文字颜色 4”。
msoThemeAccent5	9	指定配色方案“强调文字颜色 5”。
msoThemeAccent6	10	指定配色方案“强调文字颜色 6”。
msoThemeDark1	1	指定配色方案“深色 1”。
msoThemeDark2	3	指定配色方案“深色 2”。
msoThemeFollowedHyperlink	12	指定已单击超链接的配色方案。
msoThemeHyperlink	11	指定超链接的配色方案。
msoThemeLight1	2	指定配色方案“浅色 1”。
msoThemeLight2	4	指定配色方案“浅色 2”。

1.     ActiveSheet.Shapes.AddShape(msoShapeChord, 150, 131.4, 213.6, 73.8).Select
   
2.     Selection.ShapeRange.ShapeStyle = msoShapeStylePreset14
   
3.     Selection.ShapeRange.ShapeStyle = msoShapeStylePreset12
   
4.     Selection.ShapeRange.ShapeStyle = msoShapeStylePreset33
   
5.     Range("I2").Select
   
6.     ActiveSheet.Shapes.Range(Array("Chord 2")).Select
   
7.     With Selection.ShapeRange.Glow
   
8.         .Color.ObjectThemeColor = msoThemeColorAccent2
   
9.         .Color.TintAndShade = 0
   
10.         .Color.Brightness = 0
    
11.         .Transparency = 0.6000000238
    
12.         .Radius = 8
    
13.     End With
    

复制代码

luikias

思路一下子就打开咯

ning84

不能遍历所有变化。

1. Function MsoShapeType(Sld As Slide, ShapeArr, ShapeTypeArr, ShapeStyleArr)
   
2.     Dim oLeft, oTop, oWidth, oHeight
   
3.     Dim Shp As Shape, ShpRng As ShapeRange
   
4.     Dim Hh
   
5.          oLeft = 15
   
6.          oTop = 10
   
7.          oWidth = 300
   
8.          oHeight = 100
   
9.          Hh = -0
   
10.          
    
11.          For ii = 0 To UBound(ShapeArr) 'To 0 Step -1
    
12.              Set Shp = ShapeArr(ii)
    
13.              Debug.Print ii Mod 2
    
14.              With Shp
    
15.                   '.Shadow = True
    
16.                   '.AutoShapeType = ShapeArr(ii)
    
17.                   .shapestyle = ShapeStyleArr(ii)
    
18.                   If ii Mod 2 Then
    
19.                       .Left = oLeft + .Width + 80
    
20.                   Else
    
21.                       .Left = oLeft
    
22.                   End If
    
23.                   If ii Mod 2 Then
    
24.                       .Top = oTop + Hh
    
25.                       Hh = Hh + .Height + 80
    
26.                   Else
    
27.                      .Top = oTop + Hh
    
28.                   End If
    
29.                   .Width = oWidth
    
30.                   .Height = oHeight
    
31.                   '.Select
    
32.                   Set ShpRng = Sld.Shapes.Range(.Name)
    
33.                   With ShpRng
    
34.                        .TextFrame2.TextRange.Text = ShapeTypeArr(ii) & " + " & ShapeStyleArr(ii)
    
35.                        .AutoShapeType = ShapeTypeArr(ii)
    
36.                        .TextFrame2.AutoSize = msoAutoSizeShapeToFitText
    
37.                        '.Shadow = True
    
38.                   End With
    
39.                  
    
40.              End With
    
41.          Next ii
    
42. End Function

复制代码

493861364

很佩服研究ppt-vba的，各位加油！！

ning84

1. Private Sub ll3()
   
2.       Dim Pres As Presentation
   
3.       Dim xChart As Chart
   
4.       Dim Sht As Worksheet
   
5.       Dim Rng As Range
   
6.       Dim Str
   
7.         Set Pres = Application.ActivePresentation
   
8.         Set xChart = Pres.Slides(1).Shapes("C1").Chart
   
9.         ''
   
10.         xChart.ChartData.Activate
    
11.         Set Sht = xChart.ChartData.Workbook.Worksheets(1)
    
12.         Set Rng = Sht.Range("B1:I4")
    
13.     Dim Shp As Shape, Kk
    
14.     Dim Sld As Slide, oSld As Slide
    
15.     Dim SldArr() As Slide
    
16.             ReDim SldArr(2 To Rng.Columns.Count) As Slide
    
17.     Dim ShpRng As ShapeRange
    
18.     Dim TxtRng2 As TextRange2
    
19.         Set Sld = Pres.Slides(1)
    
20.         For ii = Pres.Slides.Count To 2 Step -1
    
21.              Set oSld = Pres.Slides(ii)
    
22.              Debug.Print oSld.Name
    
23.              oSld.Delete
    
24.         Next ii
    
25.         Stop
    
26.         
    
27.         For ii = 2 To Rng.Columns.Count
    
28.              Sld.Duplicate
    
29.              Set SldArr(ii) = Pres.Slides(ii)
    
30.              Debug.Print SldArr(ii).Name
    
31.         Next ii
    
32.         Stop
    
33. End Sub

复制代码

ning84

AutoShapeType属性

为指定的 Shape 或 ShapeRange对象返回或设置形状类型，除了直线、任意多边形图形或连接符外，必须表示一 AutoShape。可读写。MsoAutoShapeType 类型。

MsoAutoShapeType 可以是下列 MsoAutoShapeType 类型常数之一。

msoShapeFlowchartConnector

msoShapeFlowchartData

msoShapeFlowchartDecision

msoShapeFlowchartDelay

msoShapeFlowchartDirectAccessStorage

msoShapeFlowchartDisplay

msoShapeFlowchartDocument

msoShapeFlowchartExtract

msoShapeFlowchartInternalStorage

msoShapeFlowchartMagneticDisk

msoShapeFlowchartManualInput

msoShapeFlowchartManualOperation

msoShapeFlowchartMerge

msoShapeFlowchartMultidocument

msoShapeFlowchartOffpageConnector

msoShapeFlowchartOr

msoShapeFlowchartPredefinedProcess

msoShapeFlowchartPreparation

msoShapeFlowchartProcess

msoShapeFlowchartPunchedTape

msoShapeFlowchartSequentialAccessStorage

msoShapeFlowchartSort

msoShapeFlowchartStoredData

msoShapeFlowchartSummingJunction

msoShapeFlowchartTerminator

msoShapeFoldedCorner

msoShapeHeart

msoShapeHexagon

msoShapeHorizontalScroll

msoShapeIsoscelesTriangle

msoShapeLeftArrow

msoShapeLeftArrowCallout

msoShapeLeftBrace

msoShapeLeftBracket

msoShapeLeftRightArrow

msoShapeLeftRightArrowCallout

msoShapeLeftRightUpArrow

msoShapeLeftUpArrow

msoShapeLightningBolt

msoShapeLineCallout1

msoShapeLineCallout1AccentBar

msoShapeLineCallout1BorderandAccentBar

msoShapeLineCallout1NoBorder

msoShapeLineCallout2

msoShapeLineCallout2AccentBar

msoShapeLineCallout2BorderandAccentBar

msoShapeLineCallout2NoBorder

msoShapeLineCallout3

msoShapeLineCallout3AccentBar

msoShapeLineCallout3BorderandAccentBar

msoShapeLineCallout3NoBorder

msoShapeLineCallout4

msoShapeLineCallout4AccentBar

msoShapeLineCallout4BorderandAccentBar

msoShapeLineCallout4NoBorder

msoShapeMixed

msoShapeMoon

msoShapeNoSymbol

msoShapeNotchedRightArrow

msoShapeNotPrimitive

msoShapeOctagon

msoShapeOval

msoShapeOvalCallout

msoShapeParallelogram

msoShapePentagon

msoShapePlaque

msoShapeQuadArrow

msoShapeQuadArrowCallout

msoShapeRectangle

msoShapeRectangularCallout

msoShapeRegularPentagon

msoShapeRightArrow

msoShapeRightArrowCallout

msoShapeRightBrace

msoShapeRightBracket

msoShapeRightTriangle

msoShapeRoundedRectangle

msoShapeRoundedRectangularCallout

msoShapeSmileyFace

msoShapeStripedRightArrow

msoShapeSun

msoShapeTrapezoid

msoShapeUpArrow

msoShapeUpArrowCallout

msoShapeUpDownArrow

msoShapeUpDownArrowCallout

msoShapeUpRibbon

msoShapeUTurnArrow

msoShapeVerticalScroll

msoShapeWave

msoShapeFlowchartCollate

msoShape16pointStar

msoShape24pointStar

msoShape32pointStar

msoShape4pointStar

msoShape5pointStar

msoShape8pointStar

msoShapeActionButtonBackorPrevious

msoShapeActionButtonBeginning

msoShapeActionButtonCustom

msoShapeActionButtonDocument

msoShapeActionButtonEnd

msoShapeActionButtonForwardorNext

msoShapeActionButtonHelp

msoShapeActionButtonHome

msoShapeActionButtonInformation

msoShapeActionButtonMovie

msoShapeActionButtonReturn

msoShapeActionButtonSound

msoShapeArc

msoShapeBalloon

msoShapeBentArrow

msoShapeBentUpArrow

msoShapeBevel

msoShapeBlockArc

msoShapeCan

msoShapeChevron

msoShapeCircularArrow

msoShapeCloudCallout

msoShapeCross

msoShapeCube

msoShapeCurvedDownArrow

msoShapeCurvedDownRibbon

msoShapeCurvedLeftArrow

msoShapeCurvedRightArrow

msoShapeCurvedUpArrow

msoShapeCurvedUpRibbon

msoShapeDiamond

msoShapeDonut

msoShapeDoubleBrace

msoShapeDoubleBracket

msoShapeDoubleWave

msoShapeDownArrow

msoShapeDownArrowCallout

msoShapeDownRibbon

msoShapeExplosion1

msoShapeExplosion2

msoShapeFlowchartAlternateProcess

msoShapeFlowchartCard

expression.AutoShapeType

expression  必选。该表达式返回“应用于”列表中的对象之一。可读写。Long 类型。

注意  改变一个形状的类型时，该形状保留其大小、颜色和其他属性。

说明

使用ConnectorFormat对象的 Type属性设置或返回连接符类型。

VBA示例

本示例在myDocument 中用 16 角星替换所有 32 角星。

Set myDocument = ActivePresentation.Slides(1)

For Each s In myDocument.Shapes

    If s.AutoShapeType =msoShape16pointStar Then

        s.AutoShapeType =msoShape32pointStar

    End If

Next

ning84

自己出题自己解题

1. Function AddTextMainNoteRightNote(Shps As Shapes) ' As Object)
   
2.     Dim Shp As Shape
   
3.     Dim Str, FontSize
   
4.         Str = "fffffffff5555f"
   
5.         FontSize = 25
   
6.             Set Shp = Shps.AddTextbox(msoTextOrientationHorizontal, 5, 685, 530, FontSize * 100)
   
7.             'Shps.AddTextbox msoTextOrientationHorizontal
   
8.             Shp.Name = "MainNote"
   
9.             With Shp.TextFrame.TextRange
   
10.                  .Text = Str
    
11.                  .Font.Size = FontSize
    
12.                 .Font.Bold = msoFalse
    
13.                   
    
14.             End With
    
15.             With Shp
    
16.                   .TextFrame.AutoSize = ppAutoSizeNone
    
17.                   .ShapeStyle = msoShapeStylePreset17
    
18.                   .Height = FontSize * 2.8
    
19.             End With
    
20.             
    
21.             ''
    
22.             FontSize = 15
    
23.             Set Shp = Shps.AddTextbox(msoTextOrientationHorizontal, 0, 760, 540, FontSize + 2)
    
24.             
    
25.             Shp.Name = "RightNote"
    
26.             With Shp.TextFrame.TextRange
    
27.                  .Text = Str
    
28.                  .Font.Size = FontSize
    
29.                  .Font.Bold = msoCTrue
    
30.             End With
    
31.             Shp.TextEffect.Alignment = msoTextEffectAlignmentRight
    
32.         
    
33.         
    
34. End Function
    
35. 
    
36. 
    
37.    
    
38. ''
    
39. Sub ll2()
    
40.    Dim Pres As Presentation
    
41.        Set Pres = Application.ActivePresentation
    
42.    Dim Slds As Slides, Sld As Slide
    
43.        Set Slds = Pres.Slides
    
44.    Dim Shp As Shape, Shps As Shapes
    
45.       
    
46.       
    
47.       
    
48.        For II = 1 To Slds.Count
    
49.            Slds(II).Select
    
50.            Set Shps = Slds(II).Shapes
    
51.            Debug.Print Shps.Count
    
52.            
    
53.            For jj = Shps.Count To 2 Step -1
    
54.                Set Shp = Shps(jj)
    
55.                
    
56.                 Shp.Delete
    
57.            
    
58.            Next jj
    
59.            
    
60.            AddTextMainNoteRightNote Shps
    
61.            
    
62.        Next II
    
63. End Sub
    
64. 
    
65. Sub llll()
    
66.   Dim Shp As Shape, ShpRng As ShapeRange
    
67.   Dim Ss As Selection
    
68.   Dim T As TextEffectFormat
    
69.   Dim tt As TextRange
    
70.   Dim ttt As TextStyle
    
71.      'ttt.TextFrame.WordWrap = msoFalse
    
72.       Set Ss = Application.ActiveWindow.Selection
    
73.       Set ShpRng = Ss.ShapeRange
    
74.       ShpRng.TextFrame.AutoSize = ppAutoSizeShapeToFitText
    
75.       Stop
    
76.       ShpRng.Width = 540
    
77.       Stop
    
78.       ShpRng.TextFrame.AutoSize = ppAutoSizeNone
    
79.       Shp.Width = 540
    
80.       Stop
    
81.       Debug.Print ShpRng.Name
    
82.       ShpRng.TextFrame.WordWrap = msoFalse
    
83.       
    
84. End Sub
    

复制代码