Excel VBA質問箱 IV

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

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


16004 / 76738 ←次へ | 前へ→

【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
0 hits

【66158】二次元配列上に傾いた楕円を描画したい 10/8/6(金) 2:36 質問
【66159】Re:二次元配列上に傾いた楕円を描画したい SS 10/8/6(金) 9:25 発言
【66187】Re:二次元配列上に傾いた楕円を描画したい 10/8/6(金) 19:59 発言
【66189】Re:二次元配列上に傾いた楕円を描画したい hogeratta 10/8/6(金) 20:54 発言
【66191】Re:二次元配列上に傾いた楕円を描画したい 10/8/7(土) 4:31 発言
【66208】Re:二次元配列上に傾いた楕円を描画したい 10/8/9(月) 2:45 回答

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