(本サンプルはNTでのみ動作可能。95/98の場合、描画関数を変更すること。)
Private Sub Command1_Click() Const PI As Single = 3.14159 Dim I As Long Dim J As Long Dim Deep As Long Dim PointNum As Long Dim Points(10000) As POINT Dim Types(10000) As Byte Dim X As Long Dim Y As Long Dim A As Single Dim B As Single Dim R As Single Picture1.ScaleMode = vbPixels 'パス作成 BeginPath Picture1.hDC Ellipse Picture1.hDC, 5, 5, 150, 150 EndPath Picture1.hDC ' 線分の集合に変換し、座標を取得 FlattenPath Picture1.hDC PointNum = GetPath(Picture1.hDC, Points(0), Types(0), 10000) '注:このサンプルの場合、最初がPT_MOVETO、最後がPT_CLOSEFIGURE Or PT_LINETO、それ以外がPT_LINETOとなる If PointNum = 0 Then MsgBox "err: " & Err.LastDllError Exit Sub End If '点描 For I = 0 To PointNum - 2 Deep = (Sqr((Points(I).X - Points(I + 1).X) ^ 2 + (Points(I).Y - Points(I + 1).Y) ^ 2) + 1) * 3 For J = 1 To Deep A = Rnd B = Rnd * PI * 2 R = Rnd * 10 X = Points(I).X * A + Points(I + 1).X * (1 - A) + R * Cos(B) Y = Points(I).Y * A + Points(I + 1).Y * (1 - A) + R * Sin(B) Picture1.PSet (X, Y) Next Next End Sub