| |
▼カド さん：
こんばんは。
回答ありがとうございます。
>ずれるのは、高さ方向もですが、前面の幅の大きさが合わないですね。
>やっぱりちょっと私の手には負えないようです。
うーん、微妙なずれがあるみたいですねえ！！
このズレ、Adjustmentが上端にあるか左端にあるかで出てきているみたいです。
私がチェックした限りでは、
ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 80, 20, 30)
の場合､Width<Heightと言う関係から、Adjustmentが上端
ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 70 + 6, 20, 10)
の場合、Width>Heightと言う関係から、Adjustmentは左端
何回かサンプリングした結果、
Width<Heightの関係が成立した場合、Adjustmentが上端
それ以外の場合、Adjustmentは左端
となっていました（あくまでもサンプリングの結果ですが）。
この結果から考えると、Widthが20の場合、Heightは、16以上であれば、
Adjustmentは上端で統一できますよね？
他のには、
この３Ｄの長方形をShapeの組合せで作ってしまう方法ですが、
若干、Shapeのスケールが違いますが、以下のコードを試してみて下さい。
但し､あまり小さいと全部表示できません。
'==================================================================
Sub test()
Call mk_graph_pt(ActiveSheet, 50, 80, 15, 30)
Call mk_graph_pt(ActiveSheet, 50, 70, 15, 10)
End Sub
'======================================================================
Function mk_graph_pt(sht As Worksheet, x As Double, y As Double, w As Double, h As Double)
Dim px(1 To 4) As Double
Dim py(1 To 4) As Double
Dim para1 As Shape
Dim para2 As Shape
Dim para3 As Shape
Dim pi As Double '円周率
Dim g_nm()
pi = WorksheetFunction.pi()
px(1) = x + w + w * 0.6 * Cos(4 / 5 * pi): py(1) = y + w * 0.6 * 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.6 * Cos(4 / 5 * pi): py(4) = y + w * 0.6 * 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.6 * Cos(4 / 5 * pi): py(3) = y + w * 0.6 * Sin(4 / 5 * pi)
px(4) = x + w * 0.6 * Cos(4 / 5 * pi): py(4) = y + w * 0.6 * Sin(4 / 5 * pi)
Set para2 = Mk_Parallelogram(sht, px(), py())
Set para3 = sht.Shapes.AddShape(msoShapeRectangle, x + w * 0.6 * Cos(4 / 5 * pi), y + w * 0.6 * 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 Double, p_y() As Double, Optional cl As Long = 9) As Shape
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
高さの調整は、単純で上記のコードの方がよいと思いますが・・・。
まっ、試してみて下さい。
|
|
ichinose
- 04/9/11(土) 22:05 -
