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