Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

16000 / 76734

←次へ　｜　前へ→


	【66208】Re:二次元配列上に傾いた楕円を描画したい

芋 - 10/8/9(月) 2:45 -


	引用なし

	パスワード

疑似楕円（Y^2)^0.5=((R^2)-(X^2))^0.5+Y*n で間に合わせました
ありがとうございました

Sub daen(a, b, kaisix, kaisiy, han, x, y, katamuki, Optional owarix = 0)
'ab中心 kaisix開始X座標（1か-1のみ）kaisiy開始Y座標 han半径
'x終了X座標（1か-1のみ）y終了Y座標 katamukiてっぺんがどれだけずれてるか

Dim c, d, e, f, g, h, i, j, k, maxkata, isbyouga As Boolean, l, m
i = han ^ 2
e = kaisiy - b
d = ((i - (kaisiy - b) ^ 2) ^ 0.5) * kaisix - _
katamuki * (b - kaisiy) / han
f = ((i - (kaisiy - b - kaisix) ^ 2) ^ 0.5) * kaisix - _
katamuki * (b - kaisiy - kaisix) / han
k = -1
If f > d Then k = 1

Cells(b + e, Int(a + d)).Interior.Color = 0

For h = 0 To 2000

If k = -1 Then
If d > -katamuki Then
j = -1
Else
j = 1
End If
Else
If d < katamuki Then
j = 1
Else
j = -1
End If
End If

c = katamuki * (e + j) / han
If Abs(e) <> han Then
f = Abs(((d - c + 1) ^ 2) + ((e + j) ^ 2) - i)
g = Abs(((d - c - 1) ^ 2) + ((e + j) ^ 2) - i)
If f < g Then
k = 1
Else
k = -1
End If
End If

f = Abs(((d - c) ^ 2) + ((e + j) ^ 2) - i)
g = Abs(((d + k - katamuki * e / han) ^ 2) + (e ^ 2) - i)

If f > g And m <> -k Then
d = d + k
m = k
Else
e = e + j
m = 0
End If

Cells(b + e, Int(a + d)).Interior.Color = 0

If b + e = y Then
If x = k Then Exit For
End If

Next

owarix = a + d
End Sub

Sub test()
Cells.Clear
daen 100, 100, 1, 120, 70, 1, 150, 24
End Sub

3 hits

▼

【66158】二次元配列上に傾いた楕円を描画したい 芋 10/8/6(金) 2:36