Memo/2004-06-22

Excel 関連情報 †

サンプルコード †

オートシェイプの使い方 †

• オートシェイプを使って線を描画するサンプル（その２）

  ' オートシェイプを使って線を描画するサンプル（その２）
  ' ＜テストデータ＞
  ' 番号、X座標、Y座標、経路開始、経路終了
  '  0,  5, 49,  0,  3
  '  1,  2,  5,  0,  4
  '  2, 12,  8,  1,  2
  '  3, 45, 45,  2,  4
  '  4,  4, 21,  2,  9
  '  5, 32, 13,  9, 13
  '  6, 34, 30, 11, 13
  '  7, 30, 31,  1,  7
  '  8, 33, 24,  5,  7
  '  9, 22, 10,  5, 12
  ' 10, 20,  5
  ' 11,  8, 40
  ' 12, 11, 21
  ' 13, 37, 43
  
  Option Explicit
  
  Const g_nCount = 14 ' データ件数
  Const g_nScale = 5 ' 倍率
  Const g_nPair = 10 ' 経路数
  Const g_nX_Origin = 10 ' X軸の原点の位置
  Const g_nY_Origin = 10 ' Y軸の原点の位置
  Const g_nX_Step = 10 ' X軸の目盛りの単位
  Const g_nY_Step = 10 ' Y軸の目盛りの単位
  Const g_nX_MAX = 100 ' X軸の最大値
  Const g_nY_MAX = 100 ' Y軸の最大値
  
  ' メイン 
  Sub Main()
      DrawGrid ' 方眼用紙の作成
      DrawDot  ' 点の描画
      DrawLine ' 経路の描画
  
      ' オートシェイプのグループ化
      ActiveSheet.Shapes.SelectAll
      Selection.ShapeRange.Group.Select
  End Sub
   
  ' 方眼用紙の作成
  Sub DrawGrid()
      Dim x
      Dim y
      Dim x_st ' 線の開始位置（X軸）
      Dim y_st ' 線の開始位置（Y軸）
      Dim x_ed ' 線の終了位置（X軸）
      Dim y_ed ' 線の終了位置（Y軸）
      Dim line ' オートシェイプ：線
      Dim text ' オートシェイプ：テキストボックス
      
      ' 方眼用紙の背景の描画
      x = g_nX_Origin * g_nScale
      y = 0
      ActiveSheet.Shapes.AddShape msoShapeRectangle, x, y, g_nX_MAX * g_nScale, g_nY_MAX * g_nScale
  
      For x = 0 To g_nX_MAX Step g_nX_Step
          With ActiveSheet
              x_st = (x + g_nX_Origin) * g_nScale
              y_st = (g_nY_MAX) * g_nScale
              x_ed = (x_st)
              y_ed = (0)
              ' 線を表示（X座標、Y座標、X座標2、Y座標2）
              Set line = .Shapes.AddLine(x_st, y_st, x_ed, y_ed)
              
              ' 番号を表示（X座標、Y座標、幅、高さ）
              Set text = .Shapes.AddTextbox(msoTextOrientationHorizontal, x_st - 15, y_st + 10, 30, 15)
              text.Select
              Selection.Characters.text = CStr(x)
              Selection.HorizontalAlignment = xlCenter ' 中央揃え
              text.Fill.Visible = msoFalse ' 非表示に
              text.line.Visible = msoFalse ' 非表示に
          End With
      Next
      For y = 0 To g_nY_MAX Step g_nY_Step
          With ActiveSheet
              x_st = (g_nX_Origin) * g_nScale
              y_st = (g_nY_MAX - y) * g_nScale
              x_ed = (g_nX_Origin + g_nX_MAX) * g_nScale
              y_ed = y_st
              ' 線を表示（X座標、Y座標、X座標2、Y座標2）
              Set line = .Shapes.AddLine(x_st, y_st, x_ed, y_ed)
              
              ' 番号を表示（X座標、Y座標、幅、高さ）
              Set text = .Shapes.AddTextbox(msoTextOrientationHorizontal, x_st - 35, y_st - 5, 30, 15)
              text.Select
              Selection.Characters.text = CStr(y)
              Selection.HorizontalAlignment = xlRight ' 右寄せ
              text.Fill.Visible = msoFalse ' 非表示に
              text.line.Visible = msoFalse ' 非表示に
          End With
      Next
  End Sub
  
  ' 点の描画
  Sub DrawDot()
      Dim n ' データの番号
      Dim x ' 線の開始位置（X軸）
      Dim y ' 線の開始位置（Y軸）
      Dim i ' ループカウンタ
     
      Dim oval ' オートシェイプ：円
      Dim text ' オートシェイプ：テキストボックス
      For i = 1 To g_nCount
          n = ActiveSheet.Cells(i, 1)
          x = (g_nX_Origin + ActiveSheet.Cells(i, 2)) * g_nScale
          y = (g_nY_MAX - ActiveSheet.Cells(i, 3)) * g_nScale
          With ActiveSheet
              ' 点（○）を表示（X座標、Y座標、幅、高さ）
              Set oval = .Shapes.AddShape(msoShapeOval, x - 2, y - 2, 5, 5)
              oval.Fill.ForeColor.SchemeColor = 10 ' 色（赤）を指定
              ' 番号を表示（X座標、Y座標、幅、高さ）
              Set text = .Shapes.AddTextbox(msoTextOrientationHorizontal, x + 10, y - 5, 20, 15)
              text.Select
              Selection.Characters.text = CStr(n)
              text.Fill.Visible = msoFalse ' 非表示に
              text.line.Visible = msoFalse ' 非表示に
          End With
      Next
  End Sub
   
  ' 経路の描画
  Sub DrawLine()
      Dim n ' データの番号
      Dim x_st ' 線の開始位置（X軸）
      Dim y_st ' 線の開始位置（Y軸）
      Dim x_ed ' 線の終了位置（X軸）
      Dim y_ed ' 線の終了位置（Y軸）
      Dim i ' ループカウンタ
     
      Dim line ' オートシェイプ：線
      For i = 1 To g_nPair
          GetXY ActiveSheet.Cells(i, 4), x_st, y_st
          GetXY ActiveSheet.Cells(i, 5), x_ed, y_ed
          x_st = (g_nX_Origin + x_st) * g_nScale
          y_st = (g_nY_MAX - y_st) * g_nScale
          x_ed = (g_nX_Origin + x_ed) * g_nScale
          y_ed = (g_nY_MAX - y_ed) * g_nScale
          With ActiveSheet
              ' 線を表示（X座標、Y座標、X座標2、Y座標2）
              Set line = .Shapes.AddLine(x_st, y_st, x_ed, y_ed)
          End With
      Next
  End Sub
   
  ' 番号→座標の取得
  Function GetXY(ByVal nPos, ByRef x, ByRef y)
      Dim n
      Dim i
      x = 0
      y = 0
      For i = 1 To g_nCount
          n = ActiveSheet.Cells(i, 1)
          If n = nPos Then
              x = ActiveSheet.Cells(i, 2)
              y = ActiveSheet.Cells(i, 3)
              Exit Function
          End If
      Next
      Exit Function
  End Function

• サンプルファイル
  DrawGraph.xls

• グラフデータ
  

• 実行結果
  

• はてな
  • http://www.hatena.ne.jp/1087797083