偶尔兴致来了，练习一些图表，记录一下

493861364

micch 发表于 2023-6-1 10:22
回头单独写个代码，好像以前发过了，但是帖子太长，找不到了

期待大神佳作问世！！

micch

1. 
   
2. '// 波纹
   
3. Const Pi As Double = 3.1419265358979
   
4. Const preStr As String = "Form"
   
5. Const ColorPre As Long = &H317DED
   
6. Const ColorBac As Long = &HED7325
   
7. Dim X0, Y0, R0, D0
   
8. Dim ar0(360), cr0(360), sr0(360)
   
9. Dim xr0(360), yr0(360)
   
10. Dim V0 As Double, H0 As Double, hH As Double, L0 As Double
    
11. Dim Ra0, La0
    
12. 
    
13. Sub CreateBowen()
    
14.     Call InitiXYR
    
15.     Call GetHeightP1
    
16.     Call GetXr0Yr0
    
17.     Call DeleteShapes(Sheet1)
    
18.     Call CreateBanYuan(Sheet1, 1)
    
19.     Call CreateBanYuan(Sheet1, 2)
    
20.     Call SetYuan012Color(Sheet1)
    
21. End Sub
    
22. '---************************************
    
23. Private Sub InitiXYR()
    
24.     With Shp
    
25.         R0 = 100
    
26.         D0 = R0 * 2
    
27.         X0 = 300
    
28.         Y0 = 200
    
29.         V0 = Rnd * 0.8 + 0.1
    
30.     End With
    
31.     For j = 0 To 360 Step 1
    
32.         k = j * Pi / 180
    
33.         ar0(j) = j
    
34.         cr0(j) = R0 * Cos(k)
    
35.         sr0(j) = R0 * Sin(k)
    
36.     Next
    
37. End Sub
    
38. '---
    
39. Private Function GetHeightP1() '---垂直高度
    
40.     Dim h#
    
41.     h = V0 * D0
    
42.     y = Abs(R0 - h)
    
43.     x = VBA.Sqr(R0 ^ 2 - y ^ 2)
    
44.     L0 = x * 2
    
45.     H0 = IIf(h < R0, y, -y)
    
46.     Ra0 = Round(Application.WorksheetFunction.Asin(H0 / R0) * 180 / Pi, 0)
    
47.     If h < R0 Then La0 = (180 - Ra0) Else La0 = 180 - Ra0
    
48. End Function
    
49. '---
    
50. Private Function GetXr0Yr0()
    
51.     p = 0.5 - Abs(V0 - 0.5)
    
52.     hH = p / 8
    
53.     If h < R0 Then hH = 0.1
    
54.     t = L0 / 360
    
55.     x = -L0 / 2
    
56.     For i = 0 To 360
    
57.         xr0(i) = x
    
58.         x = x + t
    
59.         yr0(i) = sr0(i) * hH + H0
    
60.     Next
    
61. End Function
    
62. '---
    
63. Private Sub CreateBanYuan(sh As Worksheet, n%)
    
64.     Dim ar, br, cr
    
65.     ReDim ar(722)
    
66.     ReDim br(722)
    
67.     For i = 0 To 360
    
68.         If n = 1 Then
    
69.             k = i
    
70.         Else
    
71.             k = (i + 180) Mod 360
    
72.         End If
    
73.         ar(i) = xr0(i) + X0
    
74.         br(i) = yr0(k) + Y0
    
75.     Next
    
76.     For j = Ra0 To La0 Step 1
    
77.         k = (j + 360) Mod 360
    
78.         ar(i) = cr0(k) + X0
    
79.         br(i) = sr0(k) + Y0
    
80.         i = i + 1
    
81.     Next
    
82.         ar(i) = ar(0)
    
83.         br(i) = br(0)
    
84.     ReDim Preserve ar(i)
    
85.     ReDim Preserve br(i)
    
86.     cr = Application.Transpose(Array(ar, br))
    
87.     Call AddShape(sh, cr, preStr & n)
    
88. End Sub
    
89. Private Sub SetYuan012Color(sh As Worksheet)
    
90.     With sh
    
91.             .Shapes(preStr & 1).Line.Visible = msoFalse
    
92.             .Shapes(preStr & 2).Line.Visible = msoFalse
    
93.             With .Shapes(preStr & 1).Fill
    
94.                     .Visible = msoTrue
    
95.                     .ForeColor.RGB = ColorPre
    
96.                     .Transparency = 0
    
97.                     .Solid
    
98.             End With
    
99.             With .Shapes(preStr & 2).Fill
    
100.                     .Visible = msoTrue
     
101.                     .ForeColor.RGB = ColorBac
     
102.                     .Transparency = 0
     
103.                     .Solid
     
104.             End With
     
105.     End With
     
106. End Sub
     
107. Private Function DeleteShapes(sh As Worksheet)
     
108.     With sh
     
109.         For Each sp In .Shapes
     
110.         If sp.Name Like preStr & "*" Then sp.Delete
     
111.         Next
     
112.     End With
     
113. End Function
     
114. '---
     
115. Private Function AddShape(sh As Worksheet, ar, nm)
     
116.     With sh
     
117.         .Activate
     
118.         j = LBound(ar)
     
119.         With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, ar(j, 1), ar(j, 2))
     
120.                 For i = j + 1 To UBound(ar)
     
121.                     .AddNodes msoSegmentLine, msoEditingAuto, ar(i, 1), ar(i, 2)
     
122.                 Next
     
123.                 .AddNodes msoSegmentLine, msoEditingAuto, ar(j, 1), ar(j, 2)
     
124.                 .ConvertToShape.Select
     
125.         End With
     
126.         Selection.Name = nm
     
127.     End With
     
128. End Function
     
129. 
     
130. 
     

复制代码

mryys2000

感谢分享！

cyt381828864

谢谢分享，学到很多

micch

保留一下

幽情客

有练习旭日图吗？

micch

幽情客 发表于 2023-6-26 09:13
有练习旭日图吗？

旭日图Excel自带，不需要啥特殊技巧。

数据摆好，插入就行，不用系统自带的，插入圆环图也一样

机智

我的天，micch老师的图表好厉害，我现在开始看普通的图标都很吃力。羡慕

493861364

3个图表拼接的

micch

好久没作图了，想模仿一个柱形图，可惜做出来效果差很多


仿图


原图