ab.com コミュニティ

コード: 全て選択

#N88BASIC
Const Rad(N)=N*_System_PI/180
Const Per=50
Dim A As Long
Dim X As Long,Y As Long
Dim wX As Long,wY As Long
Dim mX=-1 As Long,mY=-1 As Long
Dim Win As RECT
Dim lR As Double,lG As Double,lB As Double,R As Long,G As Long,B As Long
GetClientRect(_PromptSys_hWnd,Win)
wX=Fix(Win.right/2)
wY=Fix(Win.bottom/2)
A=0
PSet(wX,wY)
Do
	X=(A/Per*Cos(Rad(A))) As Long
	Y=(A/Per*Sin(Rad(A))) As Long
	HSV2RGB(lR,lG,lB,A,1,1)
	R=Int(lR*255)
	G=Int(lG*255)
	B=Int(lB*255)
	IF mX<>X or mY<>Y then
		FullColorLine(&H80000000,&H80000000,0,X+wX,Y+wY,RGB(R,G,B))
	End If
	A++
	Sleep(1)
	If Y+wY<0 then Exit Do
	If X+wX<0 then Exit Do
	If Y-wY>0 then Exit Do
	If X-wX>0 then Exit Do
	mX=X
	mY=Y
Loop
Sleep(-1)
Sub FullColorLine(sx As Long, sy As Long, bStep As Long, ex As Long, ey As Long)(ColorCode As Long, fType As Long, BrushColor As Long)
	Dim temp As Long

	If sx=&H80000000 And sy=&H80000000 Then
		sx=_PromptSys_GlobalPos.x
		sy=_PromptSys_GlobalPos.y
	End If

	If bStep Then
		ex=sx+ex
		ey=sy+ey
	Else
		If fType Then
			If sx>ex Then
				temp=ex
				ex=sx
				sx=temp
			End If
			If sy>ey Then
				temp=ey
				ey=sy
				sy=temp
			End If
		End If
	End If

	Dim hDC As HDC
	Dim hPen As HPEN, hOldPen As VoidPtr
	Dim hBrush As HBRUSH, hOldBrush As VoidPtr

	hDC=GetDC(_PromptSys_hWnd)
	hPen=CreatePen(PS_SOLID,1,ColorCode)
	If fType=2 Then
		hBrush=CreateSolidBrush(BrushColor)
	Else
		hBrush=GetStockObject(NULL_BRUSH)
	End If

	SelectObject(hDC,hPen)
	SelectObject(hDC,hBrush)
	hOldPen=SelectObject(_PromptSys_hMemDC,hPen)
	hOldBrush=SelectObject(_PromptSys_hMemDC,hBrush)

	Select Case fType
		Case 0
			MoveToEx(_PromptSys_hMemDC,sx,sy,ByVal NULL)
			LineTo(_PromptSys_hMemDC,ex,ey)
			SetPixel(_PromptSys_hMemDC,ex,ey,ColorCode)
			MoveToEx(hDC,sx,sy,ByVal NULL)
			LineTo(hDC,ex,ey)
			SetPixel(hDC,ex,ey,ColorCode)
		Case Else
			Rectangle(hDC,sx,sy,ex+1,ey+1)
			Rectangle(_PromptSys_hMemDC,sx,sy,ex+1,ey+1)
	End Select

	ReleaseDC(_PromptSys_hWnd,hDC)
	SelectObject(_PromptSys_hMemDC,hOldPen)
	SelectObject(_PromptSys_hMemDC,hOldBrush)
	DeleteObject(hPen)
	If fType=2 Then DeleteObject(hBrush)

	_PromptSys_GlobalPos.x=ex
	_PromptSys_GlobalPos.y=ey
End Sub

Sub HSV2RGB(ByRef r As Double,ByRef g As Double,ByRef b As Double,h As Double,s As Double,v As Double)
	Dim i As Long,f As Double,p1 As Double,p2 As Double,p3 As Double
	r=0
	g=0
	b=0
	if s<0 then s=0
	if s>1 then s=1
	if v<0 then v=0
	if v>1 then v=1
	h=h Mod 360
	if h<0 then h=h+360
	h=h/60
	i=Fix(h)
	f=h-i
	p1=v*(1-s)
	p2=v*(1-s*f)
	p3=v*(1-s*(1-f))
	if i=0 then r=v:g=p3:b=p1
	if i=1 then r=p2:g=v:b=p1
	if i=2 then r=p1:g=v:b=p3
	if i=3 then r=p1:g=p2:b=v
	if i=4 then r=p3:g=p1:b=v
	if i=5 then r=v:g=p1:b=p2
End Sub