AntiAlias Line Optimization

I found this AA class on PlanetSource a few years back, and optimized it a
bit, but the code is so loosely commented that I'm honestly a bit lost in
all of it.

In any event, it's taking some 0.10 seconds to render about 60 anti-aliased
lines averaging roughly 30 pixels in length, which is severely limiting my
program's frame rate (10 FPS right there). The class creates a DIB from an
existing DC and modifies the individual pixels to create anti-aliased lines.
I'm pleased with the results as visually, it does exactly what it is
supposed to --- just that I think (hope) the code speed could be greatly
optimized.

I'm most concerned about the AALine function. It is passed the 2 XY line
points, a color, and desired line (border) thickness. My test code uses a
thickness of 1 to achieve the numbers above.

Thanks in advance,
Evan

Option Explicit

'Original TMT Pascal/Asm code by Jonas Widarsson
'
'Implemented in Vb6 by Dana Seaman
'Send comments/bug reports to dseaman@xxxxxxxxxx
'
'REVISION HISTORY
'28-Jan-2002 Created LineDIB Method
'........... Created Class
'........... Optimized code
'05-Apr-2002 First Release to PSC *(Deleted by Hacker)

'****************CODE FROM GETSETPIXEL AA MOD
******************************************

Private Type tPix 'point settings
x As Single
y As Single
alpha As Integer
End Type

Private Type tIntPix 'point settings
x As Integer
y As Integer
alpha As Integer
End Type

Private Type ColorAndAlpha
r As Byte
G As Byte
B As Byte
A As Byte
End Type

'Needed API
'Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X
As Long, ByVal Y As Long) As Long
'Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X
As Long, ByVal Y As Long, ByVal crColor As Long) As Byte
'Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal
Destination As Any, ByVal Source As Any, ByVal Length As Long)


'******************************************************


Private Type RGBQUAD
blue As Byte
green As Byte
red As Byte
Reserved As Byte
End Type

Private Type BitmapInfoHeader '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

Private Type BITMAPINFO
bmiHeader As BitmapInfoHeader
End Type

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Const DIB_RGB_COLORS As Long = 0
Private Const PS_SOLID As Long = 0

Private Binfo As BITMAPINFO
Private buf() As RGBQUAD
Private InDIBits As Boolean
Private red As Long
Private green As Long
Private blue As Long
Private m_Color As Long
Private m_hDC As Long
Private m_W1 As Long
Private m_H1 As Long
Private m_Handle As Long

Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal
OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal
hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits
As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal
hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits
As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

'Public Sub Widget(rct As RECT)

'End Sub
Private Function TranslateColour(ByVal clr As OLE_COLOR, _
Optional hPal As Long = 0) As Long
If OleTranslateColor(clr, hPal, TranslateColour) Then
TranslateColour = vbBlack 'CLR_INVALID
End If
End Function

Public Sub DIB(ByVal hDC As Long, ByVal handle As Long, ByVal W1 As Long,
ByVal H1 As Long)
m_hDC = hDC
m_Handle = handle
m_W1 = W1
m_H1 = H1
Pic2Array
End Sub

Private Sub Pic2Array()
ReDim buf(0 To (m_W1 - 1), m_H1 - 1) As RGBQUAD
With Binfo.bmiHeader
.biSize = 40
.biWidth = m_W1
.biHeight = -m_H1
.biPlanes = 1
.biBitCount = 32
.biCompression = 0
.biClrUsed = 0
.biClrImportant = 0
.biSizeImage = m_W1 * m_H1
End With
'Copy hDC to Array
GetDIBits m_hDC, m_Handle, 0, m_H1, buf(0, 0), Binfo, DIB_RGB_COLORS
'Set local flag
InDIBits = True
End Sub


Public Sub SetRGBComponents(ByVal Color As OLE_COLOR)

Color = TranslateColour(Color)
m_Color = Color 'make available global
If Color Then
red = Color And &HFF&
green = Color \ 256 And &HFF
blue = Color \ 65536
Else 'Color is Black
red = 0
green = 0
blue = 0
End If
End Sub

Public Sub Array2Pic()
'If we have an array copy back to hDC
If InDIBits Then
SetDIBits m_hDC, m_Handle, 0, m_H1, buf(0, 0), Binfo, DIB_RGB_COLORS
InDIBits = False
'Erase buf '* Moved to Class_Terminate
End If
End Sub

Private Sub Class_Terminate()
Erase buf()
End Sub


'We call only this sub, when we need to draw a line
Public Sub AALine(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single,
Color As Long, Border As Integer)

'hdc, object.hdc where we draw the line
'x1,x2,y1,y2 - start and end of the line
'Color - line color
'Border -line thicknes (border size)



If X1 = X2 And Y1 = Y2 Then Exit Sub 'we cannot drawjust a single point

'Needed variables
Dim lCount As Integer
Dim iCnt As Single
Dim iCnt2 As Integer
Dim Pp() As tPix

Dim iX1 As Single
Dim iX2 As Single
Dim iY1 As Single
Dim iY2 As Single
Dim ky As Single
Dim kx As Single

Dim A As Single
Dim a3 As Single

Dim kk As Single

Dim PPX() As tIntPix

Dim ICNT3 As Integer
Dim k As Integer
Dim iCnt0 As Integer
Dim h As Single

SetRGBComponents Color

lCount = 1
ReDim PPX(1000)
ReDim Pp(1000)
'And here we go...
If Abs(X1 - X2) >= Abs(Y1 - Y2) Then 'we separate this in two categorys -
acordingly to the angle... - the second part is the same as the first, just
x=y and y = x

'We set the new coordinates for easier drawing
If X1 > X2 Then
iX1 = X2
iX2 = X1
iY1 = Y2
iY2 = Y1
Else
iX1 = X1
iX2 = X2
iY1 = Y1
iY2 = Y2
End If

'nedded - so it draws to exact point as meant when calling the function

kk = Abs((iY1 - iY2) / (iX1 - iX2))

iX2 = iX2 + 1
iY2 = iY2 + kk


For iCnt = iX1 To iX2 Step 0.25 'we use 1/4 of a point, so that we go 4
times troug each point -> AntiAliasing = 4x
ky = (iCnt - iX1) * kk 'point y position

Pp(lCount).x = iCnt

'folowing depends on the angle...
If iY1 > iY2 Then
Pp(lCount).y = iY1 - ky
Else
Pp(lCount).y = iY1 + ky
End If

lCount = lCount + 1
If lCount > UBound(Pp) Then
ReDim Preserve Pp(lCount + 1000)
End If
Next
ReDim Preserve Pp(lCount - 1)

h = CSng(Border) 'border size

lCount = 1
If iY1 < iY2 Then 'again depends on the angle (past elese is just a
slight differnet you'll figure it out...
For iCnt0 = 1 To UBound(Pp) - 3 Step 4 'we take it by pixels (since
AntiAliasing = 4x)
For ICNT3 = Int(h - 0.001) + 1 To -1 Step -1 'we go troug to
draw different thicknes)
A = 0 'this wiil be the alpha value of the pixel (not
including the overall alpha of the line!)
For iCnt2 = 0 To 3
If ICNT3 = Int(h - 0.001 + 1) Then 'botm par of the line
a3 = Pp(iCnt0 + iCnt2).y - Int(Pp(iCnt0 + 3).y)

If a3 > h Then a3 = h

If Int(Pp(iCnt0 + iCnt2).y) < Int(Pp(iCnt0 + 3).y)
Then
a3 = 0
End If

ElseIf ICNT3 = 0 Then 'top part of the line
a3 = 1 - (Pp(iCnt0 + iCnt2).y - Int(Pp(iCnt0 +
iCnt2).y))

If a3 > h Then a3 = h
If Int(Pp(iCnt0 + iCnt2).y) < Int(Pp(iCnt0 + 3).y)
Then
If h < 1 Then
a3 = h
Else
a3 = 1
End If
End If
ElseIf ICNT3 = -1 Then 'top part of the line - just
aliasing corrections
a3 = 1 - (Pp(iCnt0 + iCnt2).y - Int(Pp(iCnt0 +
iCnt2).y))

If a3 > h Then a3 = h
If Int(Pp(iCnt0 + iCnt2).y) >= Int(Pp(iCnt0 + 3).y)
Then
a3 = 0
End If
Else 'middle part of the line (if thicknes > 1)
a3 = 1
End If

A = A + a3

If iCnt2 = 3 Then 'if the pas is = pixel x position
then we set the alpha)
PPX(lCount).x = Int(Pp(iCnt0).x)
PPX(lCount).y = Int(Pp(iCnt0 + 3).y) + ICNT3 - Int(h
/ 2)
PPX(lCount).alpha = 255 * A / 4
End If

Next iCnt2

lCount = lCount + 1
If lCount > UBound(PPX) Then
ReDim Preserve PPX(lCount + 1000)
End If
Next ICNT3
Next iCnt0
Else 'same as above just depends on the anlge...
For iCnt0 = 1 To UBound(Pp) - 3 Step 4
For ICNT3 = Int(h - 0.001) + 1 To -1 Step -1
A = 0
For iCnt2 = 0 To 3
If ICNT3 = Int(h - 0.001 + 1) Then
a3 = Pp(iCnt0 + iCnt2).y - Int(Pp(iCnt0).y)

If a3 > h Then a3 = h

If Int(Pp(iCnt0 + iCnt2).y) < Int(Pp(iCnt0).y) Then
a3 = 0
End If

ElseIf ICNT3 = 0 Then
a3 = 1 - (Pp(iCnt0 + iCnt2).y - Int(Pp(iCnt0 +
iCnt2).y))

If a3 > h Then a3 = h

If Int(Pp(iCnt0 + iCnt2).y) < Int(Pp(iCnt0).y) Then
If h < 1 Then
a3 = h
Else
a3 = 1
End If
End If
ElseIf ICNT3 = -1 Then
a3 = 1 - (Pp(iCnt0 + iCnt2).y - Int(Pp(iCnt0 +
iCnt2).y))

If a3 > h Then a3 = h
If Int(Pp(iCnt0 + iCnt2).y) >= Int(Pp(iCnt0).y) Then
a3 = 0
End If
Else
a3 = 1
End If

A = A + a3

If iCnt2 = 3 Then
PPX(lCount).x = Int(Pp(iCnt0).x)
PPX(lCount).y = Int(Pp(iCnt0).y) + ICNT3 - Int(h /
2)
PPX(lCount).alpha = 255 * A / 4
End If

Next iCnt2

lCount = lCount + 1
If lCount > UBound(PPX) Then
ReDim Preserve PPX(lCount + 1000)
End If
Next ICNT3
Next iCnt0
End If
Else

'just the same as the first part - only turned around -> x=y and y=x
If Y1 > Y2 Then
iY1 = Y2
iY2 = Y1
iX1 = X2
iX2 = X1
Else
iY1 = Y1
iY2 = Y2
iX1 = X1
iX2 = X2
End If

kk = Abs(iX1 - iX2) / Abs(iY1 - iY2)

iY2 = iY2 + 1
iX2 = iX2 + kk


For iCnt = iY1 To iY2 Step 0.25
kx = (iCnt - iY1) * kk

Pp(lCount).y = iCnt

If iX1 > iX2 Then
Pp(lCount).x = iX1 - kx
Else
Pp(lCount).x = iX1 + kx
End If

lCount = lCount + 1
If lCount > UBound(Pp) Then
ReDim Preserve Pp(lCount + 1000)
End If

Next

ReDim Preserve Pp(lCount - 1)

h = Border

If iX1 < iX2 Then
For iCnt0 = 1 To UBound(Pp) - 3 Step 4
For ICNT3 = Int(h - 0.001) + 1 To -1 Step -1
A = 0
For iCnt2 = 0 To 3
If ICNT3 = Int(h - 0.001 + 1) Then
a3 = Pp(iCnt0 + iCnt2).x - Int(Pp(iCnt0 + 3).x)

If a3 > h Then a3 = h

If Int(Pp(iCnt0 + iCnt2).x) < Int(Pp(iCnt0 + 3).x)
Then
a3 = 0
End If

ElseIf ICNT3 = 0 Then
a3 = 1 - (Pp(iCnt0 + iCnt2).x - Int(Pp(iCnt0 +
iCnt2).x))

If a3 > h Then a3 = h
If Int(Pp(iCnt0 + iCnt2).x) < Int(Pp(iCnt0 + 3).x)
Then
If h < 1 Then
a3 = h
Else
a3 = 1
End If
End If
ElseIf ICNT3 = -1 Then
a3 = 1 - (Pp(iCnt0 + iCnt2).x - Int(Pp(iCnt0 +
iCnt2).x))

If a3 > h Then a3 = h
If Int(Pp(iCnt0 + iCnt2).x) >= Int(Pp(iCnt0 + 3).x)
Then
a3 = 0
End If
Else
a3 = 1
End If

A = A + a3

If iCnt2 = 3 Then
PPX(lCount).y = Int(Pp(iCnt0).y)
PPX(lCount).x = Int(Pp(iCnt0 + 3).x) + ICNT3 - Int(h
/ 2)
PPX(lCount).alpha = 255 * A / 4
End If

Next iCnt2

lCount = lCount + 1
If lCount > UBound(PPX) Then
ReDim Preserve PPX(lCount + 1000)
End If

Next ICNT3
Next iCnt0
Else
For iCnt0 = 1 To UBound(Pp) - 3 Step 4
For ICNT3 = Int(h - 0.001) + 1 To -1 Step -1
k = UBound(PPX) + 1
ReDim Preserve PPX(k)
A = 0
For iCnt2 = 0 To 3
If ICNT3 = Int(h - 0.001 + 1) Then
a3 = Pp(iCnt0 + iCnt2).x - Int(Pp(iCnt0).x)

If a3 > h Then a3 = h

If Int(Pp(iCnt0 + iCnt2).x) < Int(Pp(iCnt0).x) Then
a3 = 0
End If

ElseIf ICNT3 = 0 Then
a3 = 1 - (Pp(iCnt0 + iCnt2).x - Int(Pp(iCnt0 +
iCnt2).x))

If a3 > h Then a3 = h

If Int(Pp(iCnt0 + iCnt2).x) < Int(Pp(iCnt0).x) Then
If h < 1 Then
a3 = h
Else
a3 = 1
End If
End If
ElseIf ICNT3 = -1 Then
a3 = 1 - (Pp(iCnt0 + iCnt2).x - Int(Pp(iCnt0 +
iCnt2).x))

If a3 > h Then a3 = h
If Int(Pp(iCnt0 + iCnt2).x) >= Int(Pp(iCnt0).x) Then
a3 = 0
End If
Else
a3 = 1
End If

A = A + a3

If iCnt2 = 3 Then
PPX(lCount).y = Int(Pp(iCnt0).y)
PPX(lCount).x = Int(Pp(iCnt0).x) + ICNT3 - Int(h /
2)
PPX(lCount).alpha = 255 * A / 4
End If

Next iCnt2

lCount = lCount + 1
If lCount > UBound(PPX) Then
ReDim Preserve PPX(lCount + 1000)
End If

Next ICNT3
Next iCnt0
End If
End If

'Passed Alpha & Color
'finaly we go trough every calculated pixel and draw it

For iCnt0 = 1 To UBound(PPX)
PutPixelDIBNew PPX(iCnt0).x, PPX(iCnt0).y, PPX(iCnt0).alpha
Next iCnt0

'and that's it;)
End Sub
Private Sub PutPixelDIBNew(ByVal x As Long, ByVal y As Long, ByVal
AlphaValue As Long)

'0, m_W1, 0, mH1 are the left/right/top/bottom bounds of our DIB

If x >= 0 And x < m_W1 And y >= 0 And y < m_H1 Then

If AlphaValue > 255 Then AlphaValue = 255

buf(x, y).red = (red * AlphaValue + buf(x, y).red * (255 -
AlphaValue)) / 255
buf(x, y).green = (green * AlphaValue + buf(x, y).green * (255 -
AlphaValue)) / 255
buf(x, y).blue = (blue * AlphaValue + buf(x, y).blue * (255 -
AlphaValue)) / 255

End If
End Sub


.

Relevant Pages

  • Re: Is there a way to prevent a RichTextBox from scrolling?
    ... Private _isRegex As Boolean ... Public Sub New(ByVal thispattern As String, ... Dim entry As tDict ...
    (microsoft.public.dotnet.framework.windowsforms.controls)
  • Project Error
    ... Private Declare Sub Sleep Lib "Kernel32" ... Dim strDataSrc As String ...
    (microsoft.public.vb.bugs)
  • MAPI Emails from Access
    ... I realize this code is quite long, but could someone take a look at the sub ... Private Const mcERR_DOH = vbObjectError + 10000 ... Private mstStatus As String ... Dim db As Database, rs As Recordset ...
    (microsoft.public.access.formscoding)
  • Re: "Subclassing" a property let
    ... Private Sub Form_Initialize ... Dim m_ForceShowInTaskbar As Boolean ... ByVal lParam As Long) As Long ...
    (microsoft.public.vb.com)
  • Re: Sorting a System.Collections.ObjectModel.Collection
    ... Public Sub Dispose() Implements System.IDisposable.Dispose ... Private m_SupportsSorting As Boolean = True ... Protected Overrides ReadOnly Property SupportsSortingCoreAs Boolean ... Dim m_SortList As New ArrayList ...
    (microsoft.public.dotnet.languages.vb)