1、采用SetPixel函数
抗锯齿算法，采用的是SetPixel函数，效率相对来说比较低下，应用DIB可以提高绘图效率，但在画少量的曲线时是看不出来差距的。（大部分代码是参考别人的）
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 Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
'*************************************************************************
'** 作 者 ： Unknown
'** 函 数 名 ： PutPixelGP
'** 输 入 ： hDC(Long) - 设备场景
'** ： x(String) - 点坐标
'** ： y(Long) - 点坐标
'** ： Strength(Long) - 长度
'** ： Red(Long) - 红色值
'** ： Green(Long) - 绿色值
'** ： Blue(Long) - 蓝色值
'** 输 出 ： 无
'** 功能描述 ： 画一个点
'** 日 期 ： 2005-10-26 22.12.31
'** 修 改 人 ： laviewpbt
'** 日 期 ： 2005-10-26 22.13.54
'** 版 本 ： Version 1.2.1
'*************************************************************************
Private Sub PutPixelGP(hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal Strength As Long, Red As Long, Green As Long, Blue As Long)
Dim Color As Long
Dim bgColor As Long
Dim Rbg As Long
Dim Gbg As Long
Dim Bbg As Long
Dim Rblend As Long
Dim Gblend As Long
Dim Bblend As Long
Dim StrengthI As Long
If Strength > 252 Then
SetPixelV hDC, X, Y, m_Color
Else
bgColor = GetPixel(hDC, X, Y)
If bgColor Then
Rbg = bgColor And &HFF&
Gbg = (bgColor And &HFF00&) / &H100&
Bbg = (bgColor And &HFF0000) / &H10000
End If
StrengthI = 255 - Strength
Rblend = StrengthI * Rbg + Strength * Red
Gblend = StrengthI * Gbg + Strength * Green
Bblend = StrengthI * Bbg + Strength * Blue
Color = RGB(Rblend / 256, Gblend / 256, Bblend / 256)
SetPixelV hDC, X, Y, Color
End If
End Sub
'*************************************************************************
'** 作 者 ： Unknown
'** 函 数 名 ： TranslateColour
'** 输 入 ： color(OLE_COLOR) - 颜色值
'** ： Red(Long) - 红色值
'** ： Green(Long) - 绿色值
'** ： Blue(Long) - 蓝色值
'** 输 出 ： 无
'** 功能描述 ： 得到颜色分量
'** 日 期 ： 2005-10-26 22.16.31
'** 修 改 人 ： laviewpbt
'** 日 期 ： 2005-10-26 22.17.28
'** 版 本 ： Version 1.2.1
'*************************************************************************
Public Sub SetRGBComponents(ByVal Color As OLE_COLOR, Red As Long, Green As Long, Blue As Long)
Color = TranslateColour(Color)
m_Color = Color
If Color Then
Red = Color And &HFF&
Green = Color / 256 And &HFF
Blue = Color / 65536
Else
Red = 0
Green = 0
Blue = 0
End If
End Sub
'*************************************************************************
'** 作 者 ： Unknown
'** 函 数 名 ： TranslateColour
'** 输 入 ： color(OLE_COLOR) - 颜色值
'** ： hPal(Long) - 0
'** 输 出 ： 无
'** 功能描述 ： 颜色转换
'** 日 期 ： 2005-10-26 22.15.23
'** 修 改 人 ： laviewpbt
'** 日 期 ： 2005-10-26 22.16.54
'** 版 本 ： Version 1.2.1
'*************************************************************************
Private Function TranslateColour(ByVal clr As OLE_COLOR, Optional hPal As Long = 0) As Long
If OleTranslateColor(clr, hPal, TranslateColour) Then
TranslateColour = vbBlack
End If
End Function
'*************************************************************************
'** 作 者 ： Unknown
'** 函 数 名 ： LineGP
'** 输 入 ： hDC(Long) - 设备场景
'** ： x1(String) - 起始坐标（以象素为单位)
'** ： y1(Integer) - 起始坐标
'** ： x2(Integer) - 终点坐标
'** ： y2(Integer) - 终点坐标
'** ： color(OLE_COLOR) - 颜色值
'** 输 出 ： 无
'** 功能描述 ： 抗锯齿算法划线
'** 日 期 ： 2005-10-26 22.10.23
'** 修 改 人 ： laviewpbt
'** 日 期 ： 2005-10-26 22.10.56
'** 版 本 ： Version 1.2.1
'*************************************************************************
Public Sub LineGP(ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal Color As OLE_COLOR)
Dim Red As Long
Dim Green As Long
Dim Blue As Long
Dim XScope As Long
Dim YScope As Long
Dim XDir As Long
Dim YDir As Long
Dim LinearDeviance As Long
Dim Counter As Long
Dim AntiAliasStrength As Long
Dim EndPointIntensity As Long
Const HalfIntensity As Long = 127
m_Color = Color
XScope = X2 - X1
YScope = Y2 - Y1
If XScope < 0 Then
XScope = Abs(XScope)
XDir = -1
Else
XDir = 1
End If
If YScope < 0 Then
YScope = Abs(YScope)
YDir = -1
Else
YDir = 1
End If
If XScope + YScope = 0 Then '如果长度为0，则退出
Exit Sub
End If
SetRGBComponents Color, Red, Green, Blue
If XScope > YScope Then
EndPointIntensity = (85 * YScope) / XScope
PutPixelGP hDC, X1 - XDir, Y1 - YDir, EndPointIntensity, Red, Green, Blue
PutPixelGP hDC, X1 - XDir, Y1, HalfIntensity, Red, Green, Blue
PutPixelGP hDC, X2 + XDir, Y2 + YDir, EndPointIntensity, Red, Green, Blue
PutPixelGP hDC, X2 + XDir, Y2, HalfIntensity, Red, Green, Blue
LinearDeviance = XScope / 2
For Counter = 0 To XScope
SetPixelV hDC, X1, Y1, m_Color
AntiAliasStrength = (LinearDeviance * 255) / XScope
PutPixelGP hDC, X1, Y1 - YDir, 255 - AntiAliasStrength, Red, Green, Blue
PutPixelGP hDC, X1, Y1 + YDir, AntiAliasStrength, Red, Green, Blue
LinearDeviance = (LinearDeviance + YScope)
If LinearDeviance >= XScope Then
LinearDeviance = LinearDeviance - XScope
Y1 = Y1 + YDir
End If
X1 = X1 + XDir
Next
Else
EndPointIntensity = (85 * XScope) / YScope
PutPixelGP hDC, X1 - XDir, Y1 - YDir, EndPointIntensity, Red, Green, Blue
PutPixelGP hDC, X1, Y1 - YDir, HalfIntensity, Red, Green, Blue
PutPixelGP hDC, X2 + XDir, Y2 + YDir, EndPointIntensity, Red, Green, Blue
PutPixelGP hDC, X2, Y2 + YDir, HalfIntensity, Red, Green, Blue
LinearDeviance = YScope / 2
For Counter = 0 To YScope
SetPixelV hDC, X1, Y1, m_Color
AntiAliasStrength = (LinearDeviance * 255) / YScope
PutPixelGP hDC, X1 - XDir, Y1, 255 - AntiAliasStrength, Red, Green, Blue
PutPixelGP hDC, X1 + XDir, Y1, AntiAliasStrength, Red, Green, Blue
LinearDeviance = LinearDeviance + XScope
If (LinearDeviance >= YScope) Then
LinearDeviance = LinearDeviance - YScope
X1 = X1 + XDir
End If
Y1 = Y1 + YDir
Next
End If
End Sub
2、采用GetDIBits
Public 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
Public 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 Type BITMAPINFOHEADER
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
Public Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
End Type
'*************************************************************************
'** 作 者 ： unknown
'** 函 数 名 ： LineDIB
'** 输 入 ： x1(String) - 起始坐标
'** ： y1(Integer) - 起始坐标
'** ： x2(Integer) - 终点坐标
'** ： y2(Integer) - 终点坐标
'** ： Color(OLE_COLOR) - 前景颜色
'** 输 出 ： 无
'** 功能描述 ： DIB插值
'** 日 期 ： 2005-10-26 23.57.12
'** 修 改 人 ： laviewpbt
'** 日 期 ： 2005-10-26 23.57.45
'** 版 本 ： Version 1.2.1
'*************************************************************************
Public Sub LineDIB(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal Color As OLE_COLOR)
If Not InDIBits Then
MsgBox "You must create a DIB array before calling LineDIB."
Exit Sub
End If
Dim Red As Long
Dim Green As Long
Dim Blue As Long
Dim XScope As Long
Dim YScope As Long
Dim XDir As Long
Dim YDir As Long
Dim LinearDeviance As Long
Dim Counter As Long
Dim AntiAliasStrength As Long
Dim EndPointIntensity As Long
Const HalfIntensity As Long = 127
XScope = X2 - X1
YScope = Y2 - Y1
If XScope < 0 Then
XScope = Abs(XScope)
XDir = -1
Else
XDir = 1
End If
If YScope < 0 Then
YScope = Abs(YScope)
YDir = -1
Else
YDir = 1
End If
If XScope + YScope = 0 Then
Exit Sub
End If
SetRGBComponents Color, Red, Green, Blue
If XScope > YScope Then
EndPointIntensity = (85 * YScope) / XScope
PutPixelDIB X1 - XDir, Y1 - YDir, EndPointIntensity, Red, Green, Blue
PutPixelDIB X1 - XDir, Y1, HalfIntensity, Red, Green, Blue
PutPixelDIB X2 + XDir, Y2 + YDir, EndPointIntensity, Red, Green, Blue
PutPixelDIB X2 + XDir, Y2, HalfIntensity, Red, Green, Blue
LinearDeviance = XScope / 2
For Counter = 0 To XScope
PutPixelDIB X1, Y1, 255, Red, Green, Blue
AntiAliasStrength = (LinearDeviance * 255) / XScope
PutPixelDIB X1, Y1 - YDir, 255 - AntiAliasStrength, Red, Green, Blue
PutPixelDIB X1, Y1 + YDir, AntiAliasStrength, Red, Green, Blue
LinearDeviance = (LinearDeviance + YScope)
If LinearDeviance >= XScope Then
LinearDeviance = LinearDeviance - XScope
Y1 = Y1 + YDir
End If
X1 = X1 + XDir
Next
Else
EndPointIntensity = (85 * XScope) / YScope
PutPixelDIB X1 - XDir, Y1 - YDir, EndPointIntensity, Red, Green, Blue
PutPixelDIB X1, Y1 - YDir, HalfIntensity, Red, Green, Blue
PutPixelDIB X2 + XDir, Y2 + YDir, EndPointIntensity, Red, Green, Blue
PutPixelDIB X2, Y2 + YDir, HalfIntensity, Red, Green, Blue
LinearDeviance = YScope / 2
For Counter = 0 To YScope
PutPixelDIB X1, Y1, 255, Red, Green, Blue
AntiAliasStrength = (LinearDeviance * 255) / YScope
PutPixelDIB X1 - XDir, Y1, 255 - AntiAliasStrength, Red, Green, Blue
PutPixelDIB X1 + XDir, Y1, AntiAliasStrength, Red, Green, Blue
LinearDeviance = LinearDeviance + XScope
If (LinearDeviance >= YScope) Then
LinearDeviance = LinearDeviance - YScope
X1 = X1 + XDir
End If
Y1 = Y1 + YDir
Next
End If
End Sub
'*************************************************************************
'** 作 者 ： unknown
'** 函 数 名 ： PutPixelDIB
'** 输 入 ： x(String) - 点坐标
'** ： y(Long) - 点坐标
'** ： Strength(Long) - 长度
'** ： Red(Long) - 红色值
'** ： Green(Long) - 绿色值
'** ： Blue(Long) - 蓝色值
'** 输 出 ： 无
'** 功能描述 ： DIB画一个点
'** 日 期 ： 2005-10-26 22.12.31
'** 修 改 人 ： laviewpbt
'** 日 期 ： 2005-10-26 22.13.54
'** 版 本 ： Version 1.2.1
'*************************************************************************
Private Sub PutPixelDIB(ByVal X As Long, ByVal Y As Long, ByVal Strength As Long, Red As Long, Green As Long, Blue As Long)
Dim Rbg As Long
Dim Gbg As Long
Dim Bbg As Long
Dim StrengthI As Long
If X < 0 Or X >= m_W1 Or Y < 0 Or Y > m_H1 Then
Exit Sub
End If
If Strength > 252 Then
buf(X, Y).Blue = Blue
buf(X, Y).Green = Green
buf(X, Y).Red = Red
Else
Bbg = buf(X, Y).Blue
Gbg = buf(X, Y).Green
Rbg = buf(X, Y).Red
StrengthI = 255 - Strength
buf(X, Y).Red = (StrengthI * Rbg + Strength * Red) / 256
buf(X, Y).Green = (StrengthI * Gbg + Strength * Green) / 256
buf(X, Y).Blue = (StrengthI * Bbg + Strength * Blue) / 256
End If
End Sub
'*************************************************************************
'** 作 者 ： unknown
'** 函 数 名 ： DIB
'** 输 入 ： hdc(Long) - 设备句柄
'** ： Handle(Long) - 位图句柄
'** ： W1(Long) - 宽度
'** ： H1(Long) - 高度
'** 输 出 ： 无
'** 功能描述 ： 初试化一个DIB
'** 日 期 ： 2005-10-26 0.03.25
'** 修 改 人 ：
'** 日 期 ：
'** 版 本 ： Version 1.2.1
'*************************************************************************
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
'*************************************************************************
'** 作 者 ： unknown
'** 函 数 名 ： Pic2Array
'** 输 入 ： 无
'** 输 出 ： 无
'** 功能描述 ： 得到DIB数据
'** 日 期 ： 2005-10-26 0.00.00
'** 修 改 人 ：
'** 日 期 ：
'** 版 本 ： Version 1.2.1
'*************************************************************************
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
GetDIBits m_hDC, m_Handle, 0, m_H1, buf(0, 0), Binfo, DIB_RGB_COLORS
InDIBits = True
End Sub
'*************************************************************************
'** 作 者 ： unknown
'** 函 数 名 ： Array2Pic
'** 输 入 ： 无
'** 输 出 ： 无
'** 功能描述 ： 显示并释放资源
'** 日 期 ： 2005-10-26 0.00.50
'** 修 改 人 ：
'** 日 期 ：
'** 版 本 ： Version 1.2.1
'*************************************************************************
Public Sub Array2Pic()
If InDIBits Then
SetDIBits m_hDC, m_Handle, 0, m_H1, buf(0, 0), Binfo, DIB_RGB_COLORS
InDIBits = False
Erase buf()
End If
End Sub
扫一扫
758
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
