VBA关于shape相关，图形，形变，变⾊，旋转效果。
shapes.addshape（ms。。。
1 先展⽰下今天做的效果
1.1 素材
按钮1：绑定start1()
按钮2：绑定stop1()
⽂字旋转效果
图形，形变，变⾊，旋转效果
四⾓星是插⼊的图形，⽂字是插⼊的艺术字（选择图形效果--选形状）
1.2 对应的代码
1. Private switch1
2.
3. Sub stop1()
4. switch1 = False
5. End Sub
6.
7.
8. Sub start1()
9. Dim p1, p2 As Shape
10. Set p1 = Worksheets('sheet1').Shapes(1)
11. Set p2 = Worksheets('sheet1').Shapes(4)
12. Set p3 = Worksheets('sheet1').Shapes('4-Point Star 3')
13.
14.
15. a = Timer
16. switch1 = True
17. Do While switch1 = True
18. DoEvents
19. If Timer - a > 0.1 Then
20. a = Timer
21. p1.IncrementRotation (10)
22. p2.Rotation = p2.Rotation + 5
23. p3.Fill.ForeColor.RGB = RGB(255 * Rnd(), 255 * Rnd(), 255 * Rnd())
24. p3.Rotation = 90 - Rnd() * 80
25. p3.Adjustments(1) = 0.2 * Rnd()
26. End If
27. Loop
28. End Sub
1.3 测试时的各种原始调试代码（废代码很多，仅做备忘）
1. Private switch1
2.
3. Sub stop1()
4. switch1 = False
5. End Sub
6.
7.
8. Sub start1()
9. Dim p1, p2 As Shape
10. Set p1 = Worksheets('sheet1').Shapes(1)
11. Set p2 = Worksheets('sheet1').Shapes(4)
12. Set p3 = Worksheets('sheet1').Shapes(3) 'shapes(3)是btn会造成拒绝的权限，实际四⾓星是shapes(5)
13. 'Set ap3 = Worksheets('sheet1').Shapes('autoshape 1')
14. Set p3 = Worksheets('sheet1').Shapes('4-Point Star 3')
15.
16. a = Timer
17. switch1 = True
18. Do While switch1 = True
19. DoEvents
20. If Timer - a > 0.1 Then
21. a = Timer
22. p1.IncrementRotation (10)
23. ' p2.Adjustments(1) = 0.1 * Rnd()
24. ' p2.IncrementRotation (10)
25. ' p2.Rotation = 360 - Rnd() * 350
26. p2.Rotation = p2.Rotation + 5
27.
28. ' p3.Adjustments.Item(1) = 0.1
29. ' p3.IncrementRotation (10)
30. ' p3.ShapeRange.Rotation = 90 - Rnd() * 80
31. ' ap3.ShapeRange.ajustments(1) = 0.1
32. p3.Fill.ForeColor.RGB = RGB(255 * Rnd(), 255 * Rnd(), 255 * Rnd())
33. p3.Rotation = 90 - Rnd() * 80
34. p3.Adjustments(1) = 0.2 * Rnd()
35.
36. End If
37. Loop
38.
39. End Sub
1.4 代码的关键点和问题总结
注意，对所要操作的具体哪⼀个 shape
有些shape 并不⽀持 rotation 等操作
⽤公共变量在2个开关程序之间传递值
每次条件满⾜，马上充值 a1=timer
1.5 报错处理（拒绝的权限和该形状已经被锁定）
拒绝的权限
该形状已经被锁定
当时忘了bt1 bt2这2个按钮我已经先添加了，这2个也是shape，这是常见思维漏洞
测试发现，button控件，可能并不⽀持选择，rotation,adjustmen(1) 等等⽅法
或者是指了sheet1⾥不存在的控件
所以这⼏种报错时要了解⼤致的问题。
2 先到shape，然后才能对其做处理
和worksheets(index) 或 worksheets('name') ⼀样
shapes()这个对象集合，也⽀持这⼏种引⽤⽅式
2.1 取得shape的 count
1. Sub test6()
2. Debug.Print Worksheets('sheet1').Shapes.Count
3. End Sub
2.2 取得shape的 index(不⽀持index()⽅法，⽤i遍历变相=index 不知道对不对 )
不⽀持index()⽅法，⽤i遍历变相=index 不知道对不对
看来index是会根据⽣成顺序重新赋值的
⽽且会去掉被删掉的index重新排序
也就说，会按照创建次序给shape赋index，⽽且如果有的shape被删除，会重新按先后次序重排
1. Sub test7()
2.
3.
4. For i = 1 To Worksheets('sheet1').Shapes.Count
5. Debug.Print Worksheets('sheet1').Shapes(i).Name & '它的index是：' & i
6. ' Debug.Print Worksheets('sheet1').Shapes(i).Index '不⽀持index⽅法？
7. Next
8.
9. End Sub
2.3 取得shape的name
1. Sub test5()
2. For i = 1 To Worksheets('sheet1').Shapes.Count
3. Debug.Print Worksheets('sheet1').Shapes(i).Name
4. Next
5. End Sub
3 shapes相关
3.1 官⽅资料
docs.microsoft/zh-cn/office/vba/api/excel.shapes
docs.microsoft/zh-cn/office/vba/api/excel.shape
github/MicrosoftDocs/VBA-Docs/blob/live/api/Excel.Shapes.AddCurve.md
3.2 shapes.Addshape(msoShapeRectangle, 200, 200, 100, 50)
官⽅⽂档
docs.microsoft/zh-cn/office/vba/api/excel.shapes.addshape
Shapes.AddShape(msoShapeRectangle, 200, 200, 100, 50)
其中200,200 这些数字单位是磅。。。
表达式。AddShape(键⼊、左、上、宽度、⾼度)
其中如果是 msoshapeRectangle, 前2个参数是左上⾓点的起点pos x,y ⽽后2个参数是矩形的2个边长,
如果在同⼀个位置，⽼shape不会被删除，但是会被新的shape 盖在上层。
改变button按钮的形状1. Sub t1()
2.
3. With Worksheets('sheet2').Shapes.AddShape(msoShapeRectangle, 200, 200, 100, 50)
4. .Name = 'tangle3'
5. .Fill.ForeColor.RGB = RGB(255, 0, 255)
6. .Line.DashStyle = msoLineDashDot
7. End With
8. End Sub
shapes.addshape(MsoAutoShapeType, left ,right ,width,height) 通⽤shapes.addshape(MsoAutoShapeType, left ,right ,width,height) 通⽤
MsoAutoShapeType可⽤的⾮常多
docs.microsoft/zh-cn/office/vba/api/office.msoautoshapetype
.Adjustments(1) = 0.2 '有黄⾊控制点的才可以调整 adjustment属性，⽐如 msoshapedimand 就没有⽐较有趣的msoautoshape总结
msoshapeOval 圆形或者椭圆，纵轴和横轴⼀样就是圆形
msoshapeRectangle
msoshape12pointStar
msoshapeBlockArc 圆弧，带厚度的
msoshapeChord 横切的部分圆形
msoshapeCross
msoshapeExplosion1 Explosion2
msoshapeGear6 只能是gear6 gear9?
msoshapeHexagon 只有6边形？ Octagon 8边型
msoShapeParallelogram
msoshapeDiamond 菱形，相当于平⾏四边形把
msoshapeSun
msoShapeIsoscelesTriangle 等腰三⾓形，可等边
msoShapeRightTriangle 直⾓三⾓形
msoshapewave
msoshapeDoublewave
其实⼤多数图像，都可以在插⼊---形状⾥直接到
1. Sub tf3()
2. Dim t1 As Double 't1不能为integer
3. Dim sp1 As Shape
4. Set sp1 = Worksheets('sheet4').Shapes.AddShape(msoShape12pointStar, 100, 100, 100, 100)
5. With sp1
6. .Fill.BackColor.RGB = RGB(0, 255, 0)
7. .Fill.ForeColor.RGB = RGB(180, 180, 180)
8. .Adjustments(1) = 0.2
9. End With
10.
11.
12.
13. t1 = Timer
14. i = 0
15. Do While i <= 100
16. DoEvents
17. If Timer - t1 > 0.1 Then
18. t1 = Timer
19. i = i + 1
20. sp1.IncrementRotation (10)
21. End If
22. Loop
23.
24. Debug.Print 'end'
25. sp1.Delete '结束时删掉这个shape
26.
27. End Sub
3.3 Shapes.AddLine(180, 180, 300, 180)
1. Sub t3()
2.
3. With Worksheets('sheet2').Shapes.AddLine(180, 180, 300, 180)
4. .Name = 'line1'
5. .Line.ForeColor.RGB = RGB(255, 100, 255)
6. .Line.DashStyle = msoLineSolid
7. End With
8. End Sub
DashStyle = msoLineSolid
msoLineSolid 等具体的参数，可以在 mscd⾥
docs.microsoft/zh-tw/office/vba/api/office.msolinedashstyle
docs.microsoft/zh-cn/dotnet/api/solinedashstyle?view=office-pia
3.4 Shapes.AddCurve SafeArrayOfPoints:=pts 贝塞尔曲线--没太理解
docs.microsoft/zh-cn/office/vba/api/excel.shapes.addcurve
由指定曲线的顶点和控制点的坐标对组成的数组。您指定的第⼀个点是起始顶点, 接下来的两个点是第⼀段贝塞尔线段的控制点。该曲线每增加⼀条线段，就要为其指定⼀个顶点和两个控制点。您指定的最后⼀个点是曲线的结束顶点。请注意，必须指定的点数始终为 3n + 1，其中 n 为曲线的线段个数。
SafeArrayOfPoints:=pts
起点，2控制点，2控制点 .....终点------好像必须是3n+1,⽐如4,7,10等等
第2维只能是2？
贝塞尔曲线
www.zhihu/question/29565629
baike.baidu/item/%E8%B4%9D%E5%A1%9E%E5%B0%94%E6%9B%B2%E7%BA%BF/1091769? fr=aladdin
它通过控制曲线上的四个点（起始点、终⽌点以及两个相互分离的中间点）来创造、编辑图形。其中起重要作⽤的是位于曲线中央的控制线。这条线是虚拟的，中间与贝塞尔曲线交叉，两端是控制端点。移动两端的端点时贝塞尔曲线改变曲线的曲率（弯曲的程度）；移动中间点（也就是移动虚拟的控制线）时，贝塞尔曲线在起始点和终⽌点锁定的情况下做均匀移动。注意，贝塞尔曲线上的所有控制点、节点均可编辑。这种“智能化”的⽮量线条为艺术家提供了⼀种理想的图形编辑与创造的⼯具。
1. Sub t5()
2. Dim pts(1 To 4, 1 To 2) As Single
3. pts(1, 1) = 10
版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。
发表评论