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

micch · 发表于 2023-5-31 12:49

数据关联一下

02761752696 · 发表于 2023-5-31 16:02

micch 发表于 2023-5-31 12:49
数据关联一下

真漂亮

这个波浪怎么做的啊，能分享下不？
我只能做一条线的

micch · 发表于 2023-5-31 16:27

本帖最后由 micch 于 2023-5-31 18:53 编辑

02761752696 发表于 2023-5-31 16:02
真漂亮

这个波浪怎么做的啊，能分享下不？

正弦曲线，用自由曲线按正弦曲线+圆的坐标点，画封闭路径。画的形状

Private Sub AddShape(sht As Worksheet, ar)
Dim K%, n%
n = UBound(ar)
With sht.Shapes.BuildFreeform(1, ar(1, 1), ar(1, 2))
For K = 1 To n
.AddNodes 0, 1, ar(K, 1), ar(K, 2)
Next
With .ConvertToShape
.Fill.ForeColor.RGB = vbBlue / 32
.Line.Weight = 1
.Line.InsetPen = True
.Name = "Form" & n - 1
End With
End With
End Sub

复制代码

eh864166675 · 发表于 2023-6-1 10:07

看着好高大上，感谢楼主分享

493861364 · 发表于 2023-6-1 10:15

micch 发表于 2023-5-31 16:27
正弦曲线，用自由曲线按正弦曲线+圆的坐标点，画封闭路径。画的形状

有代码都看不懂，看来需要学习的还有很多

micch · 发表于 2023-6-1 10:22

回头单独写个代码，好像以前发过了，但是帖子太长，找不到了

493861364 · 发表于 2023-6-1 10:39

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

期待大神佳作问世！！

micch · 发表于 2023-6-1 15:32

'// 波纹
Const Pi As Double = 3.1419265358979
Const preStr As String = "Form"
Const ColorPre As Long = &H317DED
Const ColorBac As Long = &HED7325
Dim X0, Y0, R0, D0
Dim ar0(360), cr0(360), sr0(360)
Dim xr0(360), yr0(360)
Dim V0 As Double, H0 As Double, hH As Double, L0 As Double
Dim Ra0, La0
Sub CreateBowen()
Call InitiXYR
Call GetHeightP1
Call GetXr0Yr0
Call DeleteShapes(Sheet1)
Call CreateBanYuan(Sheet1, 1)
Call CreateBanYuan(Sheet1, 2)
Call SetYuan012Color(Sheet1)
End Sub
'---************************************
Private Sub InitiXYR()
With Shp
R0 = 100
D0 = R0 * 2
X0 = 300
Y0 = 200
V0 = Rnd * 0.8 + 0.1
End With
For j = 0 To 360 Step 1
k = j * Pi / 180
ar0(j) = j
cr0(j) = R0 * Cos(k)
sr0(j) = R0 * Sin(k)
Next
End Sub
'---
Private Function GetHeightP1() '---垂直高度
Dim h#
h = V0 * D0
y = Abs(R0 - h)
x = VBA.Sqr(R0 ^ 2 - y ^ 2)
L0 = x * 2
H0 = IIf(h < R0, y, -y)
Ra0 = Round(Application.WorksheetFunction.Asin(H0 / R0) * 180 / Pi, 0)
If h < R0 Then La0 = (180 - Ra0) Else La0 = 180 - Ra0
End Function
'---
Private Function GetXr0Yr0()
p = 0.5 - Abs(V0 - 0.5)
hH = p / 8
If h < R0 Then hH = 0.1
t = L0 / 360
x = -L0 / 2
For i = 0 To 360
xr0(i) = x
x = x + t
yr0(i) = sr0(i) * hH + H0
Next
End Function
'---
Private Sub CreateBanYuan(sh As Worksheet, n%)
Dim ar, br, cr
ReDim ar(722)
ReDim br(722)
For i = 0 To 360
If n = 1 Then
k = i
Else
k = (i + 180) Mod 360
End If
ar(i) = xr0(i) + X0
br(i) = yr0(k) + Y0
Next
For j = Ra0 To La0 Step 1
k = (j + 360) Mod 360
ar(i) = cr0(k) + X0
br(i) = sr0(k) + Y0
i = i + 1
Next
ar(i) = ar(0)
br(i) = br(0)
ReDim Preserve ar(i)
ReDim Preserve br(i)
cr = Application.Transpose(Array(ar, br))
Call AddShape(sh, cr, preStr & n)
End Sub
Private Sub SetYuan012Color(sh As Worksheet)
With sh
.Shapes(preStr & 1).Line.Visible = msoFalse
.Shapes(preStr & 2).Line.Visible = msoFalse
With .Shapes(preStr & 1).Fill
.Visible = msoTrue
.ForeColor.RGB = ColorPre
.Transparency = 0
.Solid
End With
With .Shapes(preStr & 2).Fill
.Visible = msoTrue
.ForeColor.RGB = ColorBac
.Transparency = 0
.Solid
End With
End With
End Sub
Private Function DeleteShapes(sh As Worksheet)
With sh
For Each sp In .Shapes
If sp.Name Like preStr & "*" Then sp.Delete
Next
End With
End Function
'---
Private Function AddShape(sh As Worksheet, ar, nm)
With sh
.Activate
j = LBound(ar)
With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, ar(j, 1), ar(j, 2))
For i = j + 1 To UBound(ar)
.AddNodes msoSegmentLine, msoEditingAuto, ar(i, 1), ar(i, 2)
Next
.AddNodes msoSegmentLine, msoEditingAuto, ar(j, 1), ar(j, 2)
.ConvertToShape.Select
End With
Selection.Name = nm
End With
End Function

复制代码

mryys2000 · 发表于 2023-6-2 08:31

感谢分享！

cyt381828864 · 发表于 2023-6-11 17:04

谢谢分享，学到很多

		自动登录	找回密码
密码			免费注册

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

评分

评分