| |
▼カド さん：
おはようございます。再々投稿です。
理由は、後述します。
>何度もありがとうございます。
いえいえ、勉強になります・・・。
うーん、やっぱり、0.75を考慮しないと駄目ですねえ！！
それと小さい四角が作れないんです・・・。
そこで指定のWidthは、下限を15に限定してみたものを作って投稿しましたが、
不満だったので、再投稿です。
以下のコードは、
新規ブックを作成し、そのアクティブシートのセルＡ１に
作成する直方体のWidth（実際には、正面に作成される長方形のWidth）がランダム値として入力されます。
又、
セルＢ１〜セルＫ６にサンプルデータを作成し、その値に応じたグラフもどきを
Ｂ列〜Ｋ列の３０行目から作成します。
以下のコードを新規ブックの標準モジュールにコピーして試してみて下さい。
'=======================================================================
Sub test()
Dim h As Single
Dim s As Single
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
ActiveWorkbook.Close False
End If
Workbooks.Add
Cells(1, 1).Value = Int(Rnd() * 35) + 3
Call sampledata
For idx = 2 To 11
With Cells(31, idx)
h = 0
For jdx = 6 To 1 Step -1
s = Cells(jdx, idx).Value
h = h + Cells(jdx, idx).Value
Call mk_graph_pt(ActiveSheet, .Left, .Top - h, Cells(1, 1).Value, s)
Next
End With
Next
End Sub
'========================================================================
Function mk_graph_pt(sht As Worksheet, x As Single, y As Single, w As Single, h As Single)
'棒グラフ要素を作成する
'input : sht 作成するワークシート
' x,y,w,h
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()
Set para1 = sht.Shapes.AddShape(msoShapeRectangle, x, y, w, h)
With para1
px(1) = .Left + .Width: py(1) = .Top
px(2) = px(1) + Int((.Width * 0.65 * Cos(-1 / 7 * pi)) / 0.75) * 0.75
py(2) = py(1) + Int((.Width * 0.65 * Sin(-1 / 7 * pi)) / 0.75) * 0.75
px(3) = px(2): py(3) = py(2) + .Height
px(4) = .Left + .Width: py(4) = .Top + .Height
Set para2 = Mk_Parallelogram(sht, px(), py(), 22)
px(1) = .Left: py(1) = .Top
px(2) = para2.Left + para2.Width - .Width
py(2) = para2.Top
px(3) = para2.Left + para2.Width
py(3) = para2.Top
px(4) = .Left + .Width
py(4) = .Top
Set para3 = Mk_Parallelogram(sht, px(), py())
End With
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
'四角形を作成する
'input sht:ワークシートオブジェクト
' p_x(),p_y()---4点の座表の入った配列
' cl ----カラーインデックス
On Error Resume Next
Dim para As Shape '四辺形のShapeオブジェクト
Dim plus As Single
plus = 0
Do
With sht.Shapes.BuildFreeform(msoEditingAuto, p_x(1), p_y(1))
For idx = 2 To 4
.AddNodes msoSegmentLine, msoEditingAuto, p_x(idx) + plus, p_y(idx) + plus
Next idx
.AddNodes msoSegmentLine, msoEditingAuto, p_x(1), p_y(1)
Err.Clear
ret = 0
Set Mk_Parallelogram = .ConvertToShape
ret = Err.Number
If ret <> 0 Then
plus = plus + 20
ElseIf ret = 0 Then
If Mk_Parallelogram.Nodes.Count < 4 Then
ret = 1
Mk_Parallelogram.Delete
plus = plus + 20
Else
If plus > 0 Then
With Mk_Parallelogram
For idx = 2 To 4
.Nodes.SetPosition idx, p_x(idx), p_y(idx)
Next
End With
End If
Exit Do
End If
End If
End With
Loop
With Mk_Parallelogram
.Fill.ForeColor.SchemeColor = cl
.Fill.Visible = msoTrue
.Fill.Solid
End With
End Function
'=====================================================================
Sub sampledata()
For idx = 1 To 6
For jdx = 2 To 11
Cells(idx, jdx) = Int(Rnd() * 40) + 1
Next
Next
End Sub
再々投稿したのは、
1.小さい四角が作れなかったので困ってたんですが、それを可能にしため・・・。
2.上記のコードは、コードを実行するたびに新規ブックを作成しています。
同一シートに図形の削除・作成を繰り返すと強制終了が発生したためです。
メモリの問題かどうかは不明ですが。
上記のコードの場合､Book100を超えて繰り返しても正常に作動しています。
以上です。確認して下さい。
|
|
ichinose
- 04/9/15(水) 7:34 -
