Хотел прицепить картинку, но не понял как это сделать...
- Код: Выделить всё
Option Explicit
'=========Gdi32 Api========
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GdiAlphaBlend Lib "gdi32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
'=========user32 Api========
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
'=========Oleaut32 Api========
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
'=========Kernel32 Api========
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Type UcsRgbQuad
R As Byte
G As Byte
B As Byte
a As Byte
End Type
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Private Sub DrawAlphaSelection(hdc As Long, ByVal X As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As OLE_COLOR)
Dim BF As BLENDFUNCTION
Dim hDCMemory As Long
Dim hBmp As Long
Dim hOldBmp As Long
Dim DC As Long
Dim lColor As Long
Dim hPen As Long
Dim hBrush As Long
Dim lBF As Long
BF.SourceConstantAlpha = 128
DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, Width, Height)
hOldBmp = SelectObject(hDCMemory, hBmp)
hPen = CreatePen(0, 1, Color)
hBrush = CreateSolidBrush(pvAlphaBlend(Color, vbWhite, 120))
DeleteObject SelectObject(hDCMemory, hBrush)
DeleteObject SelectObject(hDCMemory, hPen)
Rectangle hDCMemory, 0, 0, Width, Height
CopyMemory VarPtr(lBF), VarPtr(BF), 4
GdiAlphaBlend hdc, X, y, Width, Height, hDCMemory, 0, 0, Width, Height, lBF
SelectObject hDCMemory, hOldBmp
DeleteObject hBmp
ReleaseDC 0&, DC
DeleteDC hDCMemory
DeleteObject hPen
DeleteObject hBrush
End Sub
Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
Dim clrFore As UcsRgbQuad
Dim clrBack As UcsRgbQuad
OleTranslateColor clrFirst, 0, VarPtr(clrFore)
OleTranslateColor clrSecond, 0, VarPtr(clrBack)
With clrFore
.R = (.R * lAlpha + clrBack.R * (255 - lAlpha)) / 255
.G = (.G * lAlpha + clrBack.G * (255 - lAlpha)) / 255
.B = (.B * lAlpha + clrBack.B * (255 - lAlpha)) / 255
End With
CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4
End Function
Private Sub Form_Paint()
Cls
DrawAlphaSelection Me.hdc, 10, 50, 100, 200, vbRed
DrawAlphaSelection Me.hdc, 50, 30, 200, 100, vbBlue
DrawAlphaSelection Me.hdc, 200, 80, 100, 100, vbGreen
DrawAlphaSelection Me.hdc, 80, 200, 200, 30, vbYellow
DrawAlphaSelection Me.hdc, 130, 70, 50, 200, vbMagenta
End Sub
