Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


63237 / 76732 ←次へ | 前へ→

【18094】Re:3次元棒グラフをマクロで描くには ちょっと訂正
発言  ichinose  - 04/9/15(水) 7:34 -

引用なし
パスワード
   ▼カド さん:
おはようございます。再々投稿です。
理由は、後述します。


>何度もありがとうございます。
いえいえ、勉強になります・・・。
うーん、やっぱり、0.75を考慮しないと駄目ですねえ!!

それと小さい四角が作れないんです・・・。
そこで指定のWidthは、下限を15に限定してみたものを作って投稿しましたが、
不満だったので、再投稿です。

以下のコードは、
新規ブックを作成し、そのアクティブシートのセルA1に
作成する直方体のWidth(実際には、正面に作成される長方形のWidth)がランダム値として入力されます。

又、
セルB1〜セルK6にサンプルデータを作成し、その値に応じたグラフもどきを
B列〜K列の30行目から作成します。


以下のコードを新規ブックの標準モジュールにコピーして試してみて下さい。

'=======================================================================
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を超えて繰り返しても正常に作動しています。


以上です。確認して下さい。
4 hits

【17918】3次元棒グラフをマクロで描くには カド 04/9/10(金) 12:32 質問
【17919】Re:3次元棒グラフをマクロで描くには IROC 04/9/10(金) 13:01 回答
【17948】Re:3次元棒グラフをマクロで描くには カド 04/9/10(金) 20:52 お礼
【17941】Re:3次元棒グラフをマクロで描くには ichinose 04/9/10(金) 18:24 発言
【17962】Re:3次元棒グラフをマクロで描くには カド 04/9/11(土) 9:36 お礼
【17963】Re:3次元棒グラフをマクロで描くには ichinose 04/9/11(土) 10:42 発言
【17964】Re:3次元棒グラフをマクロで描くには 追伸 ichinose 04/9/11(土) 10:48 発言
【17969】Re:3次元棒グラフをマクロで描くには 追伸 カド 04/9/11(土) 17:06 お礼
【17980】Re:3次元棒グラフをマクロで描くには 追伸 ichinose 04/9/11(土) 22:05 発言
【17987】Re:3次元棒グラフをマクロで描くには ち... ichinose 04/9/12(日) 0:44 発言
【18061】Re:3次元棒グラフをマクロで描くには ち... カド 04/9/14(火) 9:46 お礼
【18094】Re:3次元棒グラフをマクロで描くには ち... ichinose 04/9/15(水) 7:34 発言
【18105】Re:3次元棒グラフをマクロで描くには ち... カド 04/9/15(水) 13:46 お礼
【18107】Re:3次元棒グラフをマクロで描くには ち... カド 04/9/15(水) 16:55 お礼
【18108】Re:3次元棒グラフをマクロで描くには ち... カド 04/9/15(水) 17:54 お礼

63237 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free