| |
以下のコードで小さいサイズも作成できそうです。
'===============================================================
Sub test()
With Range("b1")
Call mk_graph_pt(ActiveSheet, .Left, 80, 15, 30)
Call mk_graph_pt(ActiveSheet, .Left, 74, 15, 6)
Call mk_graph_pt(ActiveSheet, .Left, 54, 15, 20)
End With
End Sub
'=========================================================================
Function mk_graph_pt(sht As Worksheet, x As Single, y As Single, w As Single, h As Single)
Dim px(1 To 4) As Single
Dim py(1 To 4) As Single
Dim para1 As Shape
Dim para2 As Shape
Dim para3 As Shape
Dim pi As Single '円周率
Dim g_nm()
pi = WorksheetFunction.pi()
If w < 15 Or h < 10 Then
hh = h * 10
ww = w * 10
px(1) = 150 + ww + ww * 0.8 * Cos(4 / 5 * pi): py(1) = 100 + ww * 0.8 * Sin(4 / 5 * pi)
px(2) = 150 + ww: py(2) = 100
px(3) = 150 + ww: py(3) = 100 + hh
px(4) = 150 + ww + ww * 0.8 * Cos(4 / 5 * pi): py(4) = 100 + ww * 0.8 * Sin(4 / 5 * pi) + hh
Set para1 = Mk_Parallelogram(sht, px(), py(), 22)
With para1
.Width = .Width / 10
.Height = .Height / 10
.Left = x + w + w * 0.8 * Cos(4 / 5 * pi)
.Top = y
End With
px(1) = 150: py(1) = 100
px(2) = 150 + ww: py(2) = 100
px(3) = 150 + ww + ww * 0.8 * Cos(4 / 5 * pi): py(3) = 100 + ww * 0.8 * Sin(4 / 5 * pi)
px(4) = 150 + ww * 0.8 * Cos(4 / 5 * pi): py(4) = 100 + ww * 0.8 * Sin(4 / 5 * pi)
Set para2 = Mk_Parallelogram(sht, px(), py())
With para2
.Width = .Width / 10
.Height = .Height / 10
.Left = x + w * 0.8 * Cos(4 / 5 * pi)
.Top = y
End With
Else
px(1) = x + w + w * 0.8 * Cos(4 / 5 * pi): py(1) = y + w * 0.8 * Sin(4 / 5 * pi)
px(2) = x + w: py(2) = y
px(3) = x + w: py(3) = y + h
px(4) = x + w + w * 0.8 * Cos(4 / 5 * pi): py(4) = y + w * 0.8 * Sin(4 / 5 * pi) + h
Set para1 = Mk_Parallelogram(sht, px(), py(), 22)
px(1) = x: py(1) = y
px(2) = x + w: py(2) = y
px(3) = x + w + w * 0.8 * Cos(4 / 5 * pi): py(3) = y + w * 0.8 * Sin(4 / 5 * pi)
px(4) = x + w * 0.8 * Cos(4 / 5 * pi): py(4) = y + w * 0.8 * Sin(4 / 5 * pi)
Set para2 = Mk_Parallelogram(sht, px(), py())
End If
Set para3 = sht.Shapes.AddShape(msoShapeRectangle, x + w * 0.8 * Cos(4 / 5 * pi), y + w * 0.8 * Sin(4 / 5 * pi), w, h)
g_nm() = Array(para1.Name, para2.Name, para3.Name)
Set mk_graph_pt = sht.Shapes.Range(g_nm()).Group
End Function
'=======================================================================
Function Mk_Parallelogram(sht As Worksheet, p_x() As Single, p_y() As Single, Optional cl As Long = 9) As Shape
On Error Resume Next
Dim para As Shape '四辺形のShapeオブジェクト
With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, p_x(1), p_y(1))
For idx = 2 To 4
.AddNodes msoSegmentLine, msoEditingAuto, p_x(idx), p_y(idx)
Next idx
.AddNodes msoSegmentLine, msoEditingAuto, p_x(1), p_y(1)
Set Mk_Parallelogram = .ConvertToShape
With Mk_Parallelogram
.Fill.ForeColor.SchemeColor = cl
.Fill.Visible = msoTrue
.Fill.Solid
End With
End With
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
