レーダーチャート（クモの巣）グラフ

Option Explicit

Option Compare Text

Private Declare Sub LineTo Lib "gdi32" (ByVal hdc As Long, ByVal xEnd As Long, ByVal yEnd As Long)

Private Declare Sub BitBlt Lib "gdi32" (ByVal dDestDC As Long, ByVal X As Long, ByVal Y As Long, _

ByVal nWidth As Long, ByVal nHeight As Long, _

ByVal hSrcDc As Long, ByVal xSrc As Long, ByVal ySrc As Long, _

ByVal dwRop As Long)

Private Declare Sub Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long)

Private Declare Sub TextOut Lib "gdi32" Alias "TextOutA" _

(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _

ByVal lpString As String, ByVal nCount As Long)

Private Declare Sub PaintRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long)

Private Declare Sub MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _

ByVal pLastPoint As Long)

Private Declare Sub DeleteDC Lib "gdi32" (ByVal hdc As Long)

Private Declare Sub DeleteObject Lib "gdi32" (ByVal hObject As Long)

Private Declare Function CreatePolygonRgn Lib "gdi32" (ByRef lppt As POINTAPI, ByVal cPoints As Long, _

ByVal fnPolyFillMode As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Type POINTAPI

X As Long

Y As Long

End Type

Private i As Long

Private j As Long

Private lngTextWidth As Long

Private lngTextHeight As Long

Private lngColor As Long

Private lngLineCount As Long '多角形を等分する線の数

Private lngVertexCount As Long '多角形の頂点数

Private lngRadius As Long

Private dblRadian As Double

Private Points() As POINTAPI '頂点

Private PointsCopy() As POINTAPI '頂点

Private CenterPos As POINTAPI '中心位置

Private LabelPos As POINTAPI '見出し描画位置

Private strLabel() As String '見出し文字

Private lngNumerator() As Long '分母

Private lngDenominator() As Long '分子

Private lngCompatibleDC As Long

Private Const PI As Double = 3.14159265

'fnPolyFillModeの定数

Private Const ALTERNATE As Long = 1 '交互モード

Private Const WINDING As Long = 2 '全域モード

'**********************************************************

'目的説明：フォームClickイベント

'引数：なし

'**********************************************************

'年月日区分担当者内容

'----------------------------------------------------------

'yyyy/mm/dd 新規みさきち新規作成

'**********************************************************

Private Sub Form_Click()

'ここは例です

'この例ではフォームクリックに記述していますが

'ボタンを配置しボタン押下のタイミングでも良いですし

'フォームロードで自動的に描画するのも良いでしょう。

'ジャンル

strLabel(0) = "国語"

strLabel(1) = "数学"

strLabel(2) = "理科"

strLabel(3) = "社会"

strLabel(4) = "英語"

'満点

lngNumerator(0) = 20

lngNumerator(1) = 20

lngNumerator(2) = 20

lngNumerator(3) = 20

lngNumerator(4) = 20

'塗りつぶしを複数回する場合は大きい値から先に塗りつぶしましょう

'解答数

lngDenominator(0) = 19

lngDenominator(1) = 19

lngDenominator(2) = 6

lngDenominator(3) = 20

lngDenominator(4) = 13

'多角形塗りつぶし

picDrawSpace.Cls

'デフォルトの色（白）で塗りつぶし

Call subPaintPolygon(Me, CenterPos.X, CenterPos.Y, lngVertexCount, True)

'正解数

lngDenominator(0) = 15

lngDenominator(1) = 18

lngDenominator(2) = 6

lngDenominator(3) = 14

lngDenominator(4) = 1

'こっちは黄色で塗りつぶし（第６引数で色を設定します）

Call subPaintPolygon(Me, CenterPos.X, CenterPos.Y, lngVertexCount, True, vbYellow)

'多角形描画

'等分する線は緑、外枠は濃い緑で描画

Call subDrawPolygon(Me, CenterPos.X, CenterPos.Y, lngVertexCount, &H6600&, vbGreen, lngLineCount)

Me.Refresh

End Sub

'**********************************************************

'目的説明：フォームLoadイベント

'引数：なし

'**********************************************************

'年月日区分担当者内容

'----------------------------------------------------------

'yyyy/mm/dd 新規みさきち新規作成

'**********************************************************

Private Sub Form_Load()

Dim n As Long

'今回は五角形を描画します（以下は臨機応変に変更してください）

'ここから

lngVertexCount = 5 '多角形の頂点数(ｎ角形)　３～（２角形以下はないので

lngLineCount = 5 '多角形をｍ等分する　１～（０だと外枠すらないので

lngRadius = 100 '半径

With CenterPos

.X = 180 '中心位置Ｘ座標

.Y = 150 '中心位置Ｙ座標

End With

'ここまで

n = lngVertexCount - 1

'動的配列の要素数再割り当て

ReDim Points(n)

ReDim strLabel(n)

ReDim lngNumerator(n)

ReDim lngDenominator(n)

ReDim PointsCopy(n)

For i = 0 To n

dblRadian = (360 / lngVertexCount) * i * PI / 180

With Points(i)

.X = Sin(dblRadian) * lngRadius

.Y = Cos(dblRadian) * -lngRadius

End With

Next i

With Me

.Font.Size = 9 'ここのフォントサイズは変更可能

.ScaleMode = vbPixels

.AutoRedraw = True

lngTextWidth = .TextWidth("X")

lngTextHeight = .TextHeight("X")

With .picDrawSpace

.Visible = False

.AutoRedraw = True

.ScaleMode = vbPixels

.FillStyle = vbFSSolid

.BackColor = Me.BackColor

.Move 0, 0, Me.Width \ 15, Me.Height \ 15

lngCompatibleDC = CreateCompatibleDC(.hdc)

End With

End Sub

'**********************************************************

'目的説明：フォームQueryUnloadイベント

'引数：なし

'**********************************************************

'年月日区分担当者内容

'----------------------------------------------------------

'yyyy/mm/dd 新規みさきち新規作成

'**********************************************************

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

'メモリ上に作ったDCの削除

Call DeleteDC(lngCompatibleDC)

'動的配列メモリ解放

Erase Points()

Erase PointsCopy()

Erase strLabel()

Erase lngNumerator()

Erase lngDenominator()

End Sub

'**********************************************************

'関数名：subDrawPolygon

'引数1[i]必：pObject 描画対象オブジェクト

'引数2[i]必：pX 中心Ｘ座標(Pixels)

'引数3[i]必：pY 中心Ｙ座標(Pixels)

'引数4[i]必：pN 多角形の頂点数(ｎ角形)

'引数5[i] ：pColor1 線の色

'引数6[i] ：pColor2 多角形を等分する線の色

'引数7[i] ：pGraduations 等分する数

'戻り値　：なし

'概要：多角形描画処理

'**********************************************************

'年月日区分担当者内容

'----------------------------------------------------------

'yyyy/mm/dd 新規みさきち新規作成

'**********************************************************

Private Sub subDrawPolygon(ByVal pObject As Object, _

ByVal pX As Long, _

ByVal pY As Long, _

ByVal pN As Long, _

Optional ByVal pColor1 As Long = vbBlack, _

Optional ByVal pColor2 As Long = vb3DShadow, _

Optional ByVal pGraduations As Long = 1)

Dim w_Margin As Long

Dim w_TextWidth As Long

With pObject

.ForeColor = pColor1

For i = 0 To pN - 1

'中心から頂点までの線を描画

MoveToEx pObject.hdc, pX, pY, 0

LineTo pObject.hdc, pX + Points(i).X, pY + Points(i).Y

Next i

End With

'内側から外側に向けて多角形を描画

For j = 1 To pGraduations

For i = 0 To pN - 1

With PointsCopy(i)

.X = pX + Points(i).X * j \ pGraduations

.Y = pY + Points(i).Y * j \ pGraduations

End With

Next i

If j = pGraduations Then

'一番外側の色

lngColor = pColor1

Else

'等分する線の色

lngColor = pColor2

End If

pObject.ForeColor = lngColor

'ｎ角形を描画

Call Polygon(pObject.hdc, PointsCopy(0), pN)

Next j

'見出しを描画

w_Margin = 4

For i = 0 To pN - 1

w_TextWidth = LenB(StrConv(strLabel(i), vbFromUnicode)) * lngTextWidth

With Points(i)

If .X = 0 Then

'頂点中央に描画

LabelPos.X = .X - w_TextWidth \ 2

ElseIf .X > 0 Then

'頂点の右に描画

LabelPos.X = .X + w_Margin

Else

'頂点の左に描画

LabelPos.X = .X - w_TextWidth - w_Margin

End If

If .Y = 0 Then

'頂点中央に描画

LabelPos.Y = .Y - lngTextHeight \ 2

ElseIf .Y > 0 Then

'頂点の下に描画

LabelPos.Y = .Y + w_Margin

Else

'頂点の上に描画

LabelPos.Y = .Y - lngTextHeight - w_Margin

End If

End With

TextOut pObject.hdc, LabelPos.X + pX, LabelPos.Y + pY, strLabel(i), LenB(strLabel(i))

Next i

End Sub

'**********************************************************

'関数名：subPaintPolygon

'引数1[i]必：pObject 描画対象オブジェクト

'引数2[i]必：pX 中心Ｘ座標(Pixels)

'引数3[i]必：pY 中心Ｙ座標(Pixels)

'引数4[i]必：pN 多角形の頂点数(ｎ角形)

'引数5[i] ：pZeroToAll 分母がゼロの場合の挙動［True:100％、False０％]

'引数6[i] ：pColor 着色する色

'戻り値　：なし

'概要：多角形着色処理

'**********************************************************

'年月日区分担当者内容

'----------------------------------------------------------

'yyyy/mm/dd 新規みさきち新規作成

'**********************************************************

Private Sub subPaintPolygon(ByVal pObject As Object, _

ByVal pX As Long, _

ByVal pY As Long, _

ByVal pN As Long, _

Optional ByVal pZeroToAll As Boolean = False, _

Optional ByVal pColor As Long = vbWhite)

'第５引数について…

'たとえば５ジャンルのクイズ問題をランダムに出題した結果

'出題に偏りがあり、文学歴史しか出題されなかったという場合、

'出題の無かったジャンルの出題数（分母）と解答数（分子）を

'０にすると２角形になってしまうので、デフォルトでは分母が

'０だった場合は100％となる様にしている。

Dim hRgn As Long

For i = 0 To pN - 1

With PointsCopy(i)

If lngNumerator(i) = 0 Then

'分母がゼロの場合

If pZeroToAll Then

'100％

.X = pX + Points(i).X

.Y = pY + Points(i).Y

Else

'０％

.X = pX

.Y = pY

End If

Else

.X = pX + Points(i).X * lngDenominator(i) \ lngNumerator(i)

.Y = pY + Points(i).Y * lngDenominator(i) \ lngNumerator(i)

End If

End With

Next i

With picDrawSpace

.FillColor = pColor

'領域を作成する

hRgn = CreatePolygonRgn(PointsCopy(0), pN, WINDING)

'ぬりぬり

Call PaintRgn(.hdc, hRgn)

'領域のハンドルを削除する

Call DeleteObject(hRgn)

Call BitBlt(pObject.hdc, 0, 0, .Width, .Height, .hdc, 0, 0, vbSrcCopy)

End With

End Sub

Written by みさきち