ab.com コミュニティ

Const GetRValue(rgb) = (rgb And &hff)
Const GetGValue(rgb) = ((rgb >> 8) And &hff)
Const GetBValue(rgb) = ((rgb >> 16) And &hff)

TypeDef COLORREF = DWord
TypeDef UINT = DWord

Declare Function CreateDIBSection Lib "gdi32.dll" (
	/*[in]*/  ByVal hdc As HDC,
	/*[in]*/  ByRef bmi As BITMAPINFO,
	/*[in]*/  ByVal iUsage As UINT,
	/*[out]*/ ByVal pv As *VoidPtr,
	/*[in]*/  ByVal hSection As HANDLE,
	/*[in]*/  ByVal dwOffset As DWord
) As HBITMAP

Const GetGradationColor(c1, c2, y, h) = c2 + ((c1 - c2) * y As Double / h) As Long

Function CreateGradationBitmap(
	/*[in]*/ ByRef size As SIZE,
	/*[in]*/ ByVal color1 As COLORREF,
	/*[in]*/ ByVal color2 As COLORREF) As HBITMAP

	' グラデーションビットマップを生成
	Dim BitmapInfo As BITMAPINFO
	'memset(&BitmapInfo.bmiHeader,0,sizeof(BITMAPINFOHEADER));
	With BitmapInfo.bmiHeader
		.biSize = SizeOf (BITMAPINFOHEADER)
		.biWidth = size.cx
		.biHeight = size.cy
		.biPlanes = 1
		.biBitCount = 24
	End With

	Dim hdc As HDC
	hdc = GetDC(GetDesktopWindow())

	Dim hBitmap As HBITMAP
	Dim pByte As BytePtr
	hBitmap = CreateDIBSection(hdc, BitmapInfo, DIB_RGB_COLORS, VarPtr(pByte) As *VoidPtr, 0, 0)

	Dim i As Long, i2 As Long, x As Long, y As Long
	i = BitmapInfo.bmiHeader.biWidth * 3
	If i Mod SizeOf (Long) <> 0 Then i += SizeOf (Long) - (i Mod SizeOf (Long))
	Dim height As Double
	height = BitmapInfo.bmiHeader.biHeight
	For y = 0 To BitmapInfo.bmiHeader.biHeight - 1
		Dim r As Byte, g As Byte, b As Byte
		r = GetGradationColor(GetRValue(color1), GetRValue(color2), y, height) '赤要素
		g = GetGradationColor(GetGValue(color1), GetGValue(color2), y, height) '緑要素
		b = GetGradationColor(GetBValue(color1), GetBValue(color2), y, height) '青要素
		For x = 0 To BitmapInfo.bmiHeader.biWidth - 1
			i2 = y * i + x * 3
			pByte[i2+2] = r
			pByte[i2+1] = g
			pByte[i2+0] = b
		Next
	Next

	DeleteDC(hdc)

	CreateGradationBitmap = hBitmap
End Function

[url=http://d.hatena.ne.jp/dai_optimistic/20060630/1151655105]AB開発日記 2006-06-30[/url]
ここに書かれているCreateGradationBitmap関数をABへ移植しました。
グラデーションした色を求める部分で整数型へのキャストのあたりがおそらく間違っていると思われる（※）ので，そこだけは変更してあります。
※(int)(double)LOBYTE(LOWORD(color1))略,ではなく(int)[b]([/b](double)LOBYTE(LOWORD(color1))略[b])[/b], だと思います。

[hide][code]Const GetRValue(rgb) = (rgb And &hff)
Const GetGValue(rgb) = ((rgb >> 8) And &hff)
Const GetBValue(rgb) = ((rgb >> 16) And &hff)

TypeDef COLORREF = DWord
TypeDef UINT = DWord

Declare Function CreateDIBSection Lib "gdi32.dll" (
/*[in]*/ ByVal hdc As HDC,
/*[in]*/ ByRef bmi As BITMAPINFO,
/*[in]*/ ByVal iUsage As UINT,
/*[out]*/ ByVal pv As *VoidPtr,
/*[in]*/ ByVal hSection As HANDLE,
/*[in]*/ ByVal dwOffset As DWord
) As HBITMAP

Const GetGradationColor(c1, c2, y, h) = c2 + ((c1 - c2) * y As Double / h) As Long

Function CreateGradationBitmap(
/*[in]*/ ByRef size As SIZE,
/*[in]*/ ByVal color1 As COLORREF,
/*[in]*/ ByVal color2 As COLORREF) As HBITMAP

' グラデーションビットマップを生成
Dim BitmapInfo As BITMAPINFO
'memset(&BitmapInfo.bmiHeader,0,sizeof(BITMAPINFOHEADER));
With BitmapInfo.bmiHeader
.biSize = SizeOf (BITMAPINFOHEADER)
.biWidth = size.cx
.biHeight = size.cy
.biPlanes = 1
.biBitCount = 24
End With

Dim hdc As HDC
hdc = GetDC(GetDesktopWindow())

Dim hBitmap As HBITMAP
Dim pByte As BytePtr
hBitmap = CreateDIBSection(hdc, BitmapInfo, DIB_RGB_COLORS, VarPtr(pByte) As *VoidPtr, 0, 0)

Dim i As Long, i2 As Long, x As Long, y As Long
i = BitmapInfo.bmiHeader.biWidth * 3
If i Mod SizeOf (Long) <> 0 Then i += SizeOf (Long) - (i Mod SizeOf (Long))
Dim height As Double
height = BitmapInfo.bmiHeader.biHeight
For y = 0 To BitmapInfo.bmiHeader.biHeight - 1
Dim r As Byte, g As Byte, b As Byte
r = GetGradationColor(GetRValue(color1), GetRValue(color2), y, height) '赤要素
g = GetGradationColor(GetGValue(color1), GetGValue(color2), y, height) '緑要素
b = GetGradationColor(GetBValue(color1), GetBValue(color2), y, height) '青要素
For x = 0 To BitmapInfo.bmiHeader.biWidth - 1
i2 = y * i + x * 3
pByte[i2+2] = r
pByte[i2+1] = g
pByte[i2+0] = b
Next
Next

DeleteDC(hdc)

CreateGradationBitmap = hBitmap
End Function[/code][/hide]