ここに書かれているCreateGradationBitmap関数をABへ移植しました。
グラデーションした色を求める部分で整数型へのキャストのあたりがおそらく間違っていると思われる（※）ので，そこだけは変更してあります。
※(int)(double)LOBYTE(LOWORD(color1))略,ではなく(int)((double)LOBYTE(LOWORD(color1))略), だと思います。
[ここをクリックすると内容が表示されます]
コード: 全て選択
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