VBA 关于shape相关，图形，形变，变色，旋转效果。shapes.addshape (msoAutoShapeType)的属性，方法等

最新推荐文章于 2023-12-13 10:40:51 发布

奔跑的犀牛先生

最新推荐文章于 2023-12-13 10:40:51 发布

阅读量1.2w

点赞数 6

本文链接：https://blog.csdn.net/xuemanqianshan/article/details/112072171

版权

1 先展示下今天做的效果

1.1 素材

按钮1：绑定start1()
按钮2：绑定stop1()
文字旋转效果
图形，形变，变色，旋转效果
四角星是插入的图形，文字是插入的艺术字（选择图形效果--选形状）

1.2 对应的代码

Private switch1

Sub stop1()
switch1 = False
End Sub


Sub start1()
Dim p1, p2 As Shape
Set p1 = Worksheets("sheet1").Shapes(1)
Set p2 = Worksheets("sheet1").Shapes(4)
Set p3 = Worksheets("sheet1").Shapes("4-Point Star 3")


a = Timer
switch1 = True
Do While switch1 = True
DoEvents
If Timer - a > 0.1 Then
   a = Timer
    p1.IncrementRotation (10)
    p2.Rotation = p2.Rotation + 5
    p3.Fill.ForeColor.RGB = RGB(255 * Rnd(), 255 * Rnd(), 255 * Rnd())
    p3.Rotation = 90 - Rnd() * 80
    p3.Adjustments(1) = 0.2 * Rnd()
End If
Loop
End Sub

1.3 测试时的各种原始调试代码（废代码很多，仅做备忘）

Private switch1

Sub stop1()
switch1 = False
End Sub


Sub start1()
Dim p1, p2 As Shape
Set p1 = Worksheets("sheet1").Shapes(1)
Set p2 = Worksheets("sheet1").Shapes(4)
Set p3 = Worksheets("sheet1").Shapes(3) 'shapes(3)是btn会造成拒绝的权限，实际四角星是shapes(5)
'Set ap3 = Worksheets("sheet1").Shapes("autoshape 1")
Set p3 = Worksheets("sheet1").Shapes("4-Point Star 3")

a = Timer
switch1 = True
Do While switch1 = True
DoEvents
If Timer - a > 0.1 Then
   a = Timer
    p1.IncrementRotation (10)
'    p2.Adjustments(1) = 0.1 * Rnd()
'    p2.IncrementRotation (10)
'     p2.Rotation = 360 - Rnd() * 350
      p2.Rotation = p2.Rotation + 5

'    p3.Adjustments.Item(1) = 0.1
'     p3.IncrementRotation (10)
'     p3.ShapeRange.Rotation = 90 - Rnd() * 80
'      ap3.ShapeRange.ajustments(1) = 0.1
       p3.Fill.ForeColor.RGB = RGB(255 * Rnd(), 255 * Rnd(), 255 * Rnd())
       p3.Rotation = 90 - Rnd() * 80
       p3.Adjustments(1) = 0.2 * Rnd()
     
End If
Loop

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

Sub test6()
   Debug.Print Worksheets("sheet1").Shapes.Count
End Sub

2.2 取得shape的 index(不支持index()方法，用i遍历变相=index 不知道对不对 )

不支持index()方法，用i遍历变相=index 不知道对不对
看来index是会根据生成顺序重新赋值的
而且会去掉被删掉的index重新排序
也就说，会按照创建次序给shape赋index，而且如果有的shape被删除，会重新按先后次序重排

Sub test7()


For i = 1 To Worksheets("sheet1").Shapes.Count
   Debug.Print Worksheets("sheet1").Shapes(i).Name & "它的index是：" & i
'   Debug.Print Worksheets("sheet1").Shapes(i).Index  '不支持index方法？
Next

End Sub

2.3 取得shape的name

Sub test5()
For i = 1 To Worksheets("sheet1").Shapes.Count
   Debug.Print Worksheets("sheet1").Shapes(i).Name
Next
End Sub

3 shapes相关

3.1 官方资料

3.2 shapes.Addshape(msoShapeRectangle, 200, 200, 100, 50)

官方文档
https://docs.microsoft.com/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 盖在上层。

Sub t1()

With Worksheets("sheet2").Shapes.AddShape(msoShapeRectangle, 200, 200, 100, 50)
     .Name = "tangle3"
     .Fill.ForeColor.RGB = RGB(255, 0, 255)
     .Line.DashStyle = msoLineDashDot
End With
End Sub

shapes.addshape(MsoAutoShapeType, left ,right ,width,height) 通用

shapes.addshape(MsoAutoShapeType, left ,right ,width,height) 通用
MsoAutoShapeType 可用的非常多
https://docs.microsoft.com/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
其实大多数图像，都可以在插入---形状里直接找到

Sub tf3()
Dim t1 As Double   't1不能为integer
Dim sp1 As Shape
Set sp1 = Worksheets("sheet4").Shapes.AddShape(msoShape12pointStar, 100, 100, 100, 100)
With sp1
     .Fill.BackColor.RGB = RGB(0, 255, 0)
     .Fill.ForeColor.RGB = RGB(180, 180, 180)
     .Adjustments(1) = 0.2
End With



t1 = Timer
i = 0
Do While i <= 100
   DoEvents
   If Timer - t1 > 0.1 Then
     t1 = Timer
     i = i + 1
     sp1.IncrementRotation (10)
   End If
Loop

Debug.Print "end"
sp1.Delete           '结束时删掉这个shape

End Sub

3.3 Shapes.AddLine(180, 180, 300, 180)

Sub t3()

With Worksheets("sheet2").Shapes.AddLine(180, 180, 300, 180)
     .Name = "line1"
     .Line.ForeColor.RGB = RGB(255, 100, 255)
     .Line.DashStyle = msoLineSolid
End With
End Sub

DashStyle = msoLineSolid
msoLineSolid 等具体的参数，可以在 mscd里找
https://docs.microsoft.com/zh-tw/office/vba/api/office.msolinedashstyle
https://docs.microsoft.com/zh-cn/dotnet/api/microsoft.office.core.msolinedashstyle?view=office-pia

3.4 Shapes.AddCurve SafeArrayOfPoints:=pts 贝塞尔曲线--没太理解

https://docs.microsoft.com/zh-cn/office/vba/api/excel.shapes.addcurve
由指定曲线的顶点和控制点的坐标对组成的数组。您指定的第一个点是起始顶点, 接下来的两个点是第一段贝塞尔线段的控制点。该曲线每增加一条线段，就要为其指定一个顶点和两个控制点。您指定的最后一个点是曲线的结束顶点。请注意，必须指定的点数始终为 3n + 1，其中 n 为曲线的线段个数。
SafeArrayOfPoints:=pts
起点，2控制点，2控制点 .....终点------好像必须是3n+1,比如4,7,10等等
第2维只能是2？

贝塞尔曲线

https://www.zhihu.com/question/29565629

https://baike.baidu.com/item/%E8%B4%9D%E5%A1%9E%E5%B0%94%E6%9B%B2%E7%BA%BF/1091769?fr=aladdin

它通过控制曲线上的四个点（起始点、终止点以及两个相互分离的中间点）来创造、编辑图形。其中起重要作用的是位于曲线中央的控制线。这条线是虚拟的，中间与贝塞尔曲线交叉，两端是控制端点。移动两端的端点时贝塞尔曲线改变曲线的曲率（弯曲的程度）；移动中间点（也就是移动虚拟的控制线）时，贝塞尔曲线在起始点和终止点锁定的情况下做均匀移动。注意，贝塞尔曲线上的所有控制点、节点均可编辑。这种“智能化”的矢量线条为艺术家提供了一种理想的图形编辑与创造的工具。

Sub t5()
Dim pts(1 To 4, 1 To 2) As Single
pts(1, 1) = 10
pts(1, 2) = 50

pts(2, 1) = 200
pts(2, 2) = 120

pts(3, 1) = 150
pts(3, 2) = 210

pts(4, 1) = 310
pts(4, 2) = 220

Worksheets("sheet4").Shapes.AddCurve SafeArrayOfPoints:=pts

End Sub

4 shape相关效果

官方资料

https://docs.microsoft.com/zh-cn/office/vba/api/excel.shape

4.1 简单汇总（乱的，先记着）

shape.IncrementRotation (10) 文本顺时针旋转10度
shape.Fill.ForeColor.RGB = RGB(255 * Rnd(), 255 * Rnd(), 255 * Rnd()) 变色
shape.Rotation = 90 - Rnd() * 80 两种旋转的区别
shape.Adjustments(1) = 0.2 * Rnd() 相当于控制图像的黄色变形点操作
shape.name=
shape.index=
shape.ForeColor.RGB = RGB(255, 0, 255)
shape.BackColor.RGB = RGB(255, 0, 255) '什么情况生效？
shape.Line.DashStyle = msoLineDashDot
.Adjustments(1) = 0.2 '有黄色控制点的才可以调整 adjustment属性，比如 msoshapedimand 就没有

4.2 旋转相关

shape.incrementRotation() '绕Z轴旋转，也就是垂直于屏幕（的Z轴）旋转
shape.incrementRotationZ()
shape.incrementRotationX() ' 很多形状并不支持,需要3D的才支持
shape.incrementRotationY()
shape.Rotation()

4.3 颜色相关

shape.forecolor.rgb=rgb()
shape.forecolor.rgb=rgb()

4.4 形状相关

shape.adjustment

4.5 线，边框相关

shape.line.

奔跑的犀牛先生

关注

6
点赞
踩
64

收藏

觉得还不错? 一键收藏
0
评论
VBA 关于shape相关，图形，形变，变色，旋转效果。shapes.addshape (msoAutoShapeType)的属性，方法等

先展示下今天做的效果按钮1：绑定start1() 按钮2：绑定stop1() 文字旋转效果图形，形变，变色，旋转效果四角星是插入的图形，文字是插入的艺术字（选择图形效果--选形状）对应的代码Private switch1Sub stop1()switch1 = FalseEnd SubSub start1()Dim p1, p2 As ShapeSet p1 = Worksheets("sheet1").Shapes(1)Set p2 = Workshe...
复制链接

扫一扫