Добавляем в модуль:
| Код |
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public Function LineAA(hdc As Long, x1 As Long, y1 As Long, x2 As Long, _
y2 As Long, AColor As Long)
Dim deltax As Integer, deltay As Integer, loopc As Integer
Dim start As Integer, finish As Integer
Dim dx As Single, dy As Single, dydx As Single
Dim LR As Byte, LG As Byte, LB As Byte
Dim pt As POINTAPI
Dim hPen As Long
deltax = Abs(x2 - x1)
deltay = Abs(y2 - y1)
If (deltax <> 0) And (deltay <> 0) Then
LR = (AColor And &HFF&)
LG = (AColor And &HFF00&) / &H100&
LB = (AColor And &HFF0000) / &H10000
If deltax > deltay Then
If y2 > y1 Then
dydx = -(deltay / deltax)
Else
dydx = deltay / deltax
End If
If x2 < x1 Then
start = x2
finish = x1
dy = y2
Else
start = x1
finish = x2
dy = y1
dydx = -dydx
End If
For loopc = start To finish
AlphaBlendPixel hdc, loopc, CInt(dy - 0.5), LR, LG, LB, _
1 - FracPart(dy)
AlphaBlendPixel hdc, loopc, CInt(dy - 0.5) + 1, LR, LG, _
LB, FracPart(dy)
dy = dy + dydx
Next loopc
Else
If x2 > x1 Then
dydx = -(deltax / deltay)
Else
dydx = deltax / deltay
End If
If y2 < y1 Then
start = y2
finish = y1
dx = x2
Else
start = y1
finish = y2
dx = x1
dydx = -dydx
End If
For loopc = start To finish
AlphaBlendPixel hdc, CInt(dx - 0.5), loopc, LR, LG, LB, _
1 - FracPart(dx)
AlphaBlendPixel hdc, CInt(dx - 0.5) + 1, loopc, LR, LG, _
LB, FracPart(dx)
dx = dx + dydx
Next loopc
End If
Else
hPen = CreatePen(0, 1, AColor)
SelectObject hdc, hPen
MoveToEx hdc, x1, y1, pt
LineTo hdc, x2, y2
DeleteObject hPen
End If
End Function
Private Function AlphaBlendPixel(ByVal hdc As Long, ByVal x As Integer, _
ByVal y As Integer, ByVal R As Byte, ByVal g As Byte, ByVal b As Byte, _
ByVal ARatio As Double)
Dim LMinusRatio As Double
Dim nr As Byte, ng As Byte, nb As Byte
Dim dStc As Long, dr As Byte, dg As Byte, db As Byte
LMinusRatio = 1 - ARatio
dStc = GetPixel(hdc, x, y)
dr = (dStc And &HFF&)
dg = (dStc And &HFF00&) / &H100&
db = (dStc And &HFF0000) / &H10000
nb = Round(b * ARatio + db * LMinusRatio)
ng = Round(g * ARatio + dg * LMinusRatio)
nr = Round(R * ARatio + dr * LMinusRatio)
SetPixel hdc, x, y, RGB(nr, ng, nb)
End Function
Private Function FracPart(ByVal a As Double) As Double
Dim b As Double
b = CLng(a - 0.5)
FracPart = a - b
End Function
|
|