类模块代码
Option Explicit
Private wp As Long
Private hp As Long
Private nColor As Long
Private wb As Long
Private hLine As Long
Private infoPtr As Long
Private bytePtr As Long
Private bi() As Long
Private byteBmp() As Byte
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, ByVal lpBits As Long, ByVal lpBitsInfo As Long, ByVal wUsage As Long, ByVal dwRop As Long) As Long
Private Const DIB_RGB_COLORS = 0 '
color table in RGBs
Private Const DIB_PAL_COLORS = 1 '
color table in palette indices
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Public Sub createBmp8Bit(w As Long, h As Long, nCorlor As Long)
If nCorlor = 0 Or nCorlor > 1024 Then nCorlor = 1024
ReDim bi(10 + nCorlor - 1)
bi(0) = 40
wp = w
bi(1) = w
hp = h
bi(2) = h
bi(3) = 8& * 2 ^ 16 + 1&
bi(8) = nCorlor
bi(9) = nCorlor
bi(10) = 255 * 2 ^ 16 + 255 * 2 ^ 8 + 255
bi(11) = 255 * 2 ^ 16 + 255 * 2 ^ 8
bi(12) = 255 * 2 ^ 8 + 255
bi(13) = 255 * 2 ^ 16 + 255
bi(14) = 255 * 2 ^ 16
bi(15) = 255 * 2 ^ 8
bi(16) = 255
bi(17) = 0
wb = ((w + 3) \ 4) * 4
If h > 0 Then
hLine = h
ElseIf h < 0 Then
hLine = -h
Else
hLine = 1
End If
ReDim byteBmp(wb * hLine - 1)
infoPtr = VarPtr(bi(0))
bytePtr = VarPtr(byteBmp(0))
End Sub
Public Sub setpixel(x As Long, y As Long, color As Long)
If x >= 0 And x < wp And y >= 0 And y < hLine Then byteBmp(y * wb + x) = color
End Sub
Public Function getpixel(x As Long, y As Long) As Long
If x >= 0 And x < wp And y >= 0 And y < hLine Then
getpixel = byteBmp(y * wb + x)
Else
getpixel = -1
End If
End Function
Private Sub setpixel_(x As Long, y As Long, color As Long)
byteBmp(y * wb + x) = color
End Sub
Private Function getpixel_(x As Long, y As Long) As Long
getpixel_ = byteBmp(y * wb + x)
End Function
Public Sub myLine(x1 As Long, y1 As Long, x2 As Long, y2 As Long, color As Long)
Dim x As Long, y As Long
Dim k As Long
Dim dx As Long, dy As Long
'''''''''' cut
If x1 < 0 And x2 < 0 Or x1 >= wp And x2 >= wp _
Or y1 < 0 And y2 < 0 Or y1 >= wp And y2 >= wp Then Exit Sub
''''''''''''cut
'''''''''
1
If x1 = x2 Then
For y = IIf(y1 <= y2, y1, y2) To IIf(y1 > y2, y1, y2)
setpixel x1, y, color
Next
Exit Sub
End If
'''''''''
2
If y1 = y2 Then
For x = IIf(x1 <= x2, x1, x2) To IIf(x1 > x2, x1, x2)
setpixel x, y1, color
Next
Exit Sub
End If
'''''''''
If x1 > x2 Then
x = x1
x1 = x2
x2 = x
y = y1
y1 = y2
y2 = y
End If
If y1 > y2 Then
y1 = -y1
y2 = -y2
k = -1
Else
k = 1
End If
'''''''''''''''''''
dx = x2 - x1
dy = y2 - y1
'''''''''
3
If dx = dy Then
y = y1
For x = x1 To x2
setpixel x, y * k, color
y = y + 1
Next
Exit Sub
End If
''''''''''''''''''''
Dim c1 As Long, c2 As Long, f As Long
''''''''''''''''''''''''''4
If dx > dy Then
c1 = dy + dy
c2 = c1 - dx - dx
f = c1 - dx
x = x1
y = y1
setpixel x, y * k, color
Do While x < x2
x = x + 1
If f < 0 Then
f = f + c1
Else
f = f + c2
y = y + 1
End If
setpixel x, y * k, color
Loop
Exit Sub
End If
'''''''''''''''''''''''''''''''''
5
c1 = dx + dx
c2 = c1 - dy - dy
f = c1 - dy
x = x1
y = y1
setpixel x, y * k, color
Do While y < y2
y = y + 1
If f < 0 Then
f = f + c1
Else
f = f + c2
x = x + 1
End If
setpixel x, y * k, color
Loop
End Sub
Public Sub vLine(x1 As Long, x2 As Long, y As Long, color As Long)
If x1 < 0 And x2 < 0 Or x1 >= wp And x2 >= wp Or y < 0 Or y >= hLine Then Exit Sub
If x1 < 0 Then x1 = 0
If x2 < 0 Then x2 = 0
If x1 >= wb Then x1 = wb - 1
If x2 >= wb Then x2 = wb - 1
Dim yb As Long, x As Long, k As Long
yb = y * wb
k = IIf(x1 < x2, 1, -1)
For x = x1 To x2 Step k
byteBmp(yb + x) = color
Next
End Sub
Private Sub vLine_(x1 As Long, x2 As Long, y As Long, color As Long)
Dim yb As Long, x As Long, k As Long
yb = y * wb
k = IIf(x1 < x2, 1, -1)
For x = x1 To x2 Step k
byteBmp(yb + x) = color
Next
End Sub
Public Sub hhLine(x As Long, y1 As Long, y2 As Long, color As Long)
If x < 0 Or x >= wp _
Or y1 < 0 And y2 < 0 Or y1 >= hLine And y2 >= hLine Then Exit Sub
If y1 < 0 Then y1 = 0
If y2 < 0 Then y2 = 0
If y1 >= hLine Then y1 = hLine - 1
If y2 >= hLine Then y2 = hLine - 1
Dim y As Long, yb As Long, k As Long
k = IIf(y1 < y2, 1, -1)
yb = y1 * wb + x
For y = y1 To y2 Step k
byteBmp(yb) = color
yb = yb + wb * k
Next
End Sub
Private Sub hLine_(x As Long, y1 As Long, y2 As Long, color As Long)
Dim y As Long, yb As Long, k As Long
k = IIf(y1 < y2, 1, -1)
yb = y1 * wb + x
For y = y1 To y2 Step k
byteBmp(yb) = color
yb = yb + wb * k
Next
End Sub
Public Sub rectangle(x1 As Long, y1 As Long, x2 As Long, y2 As Long, color As Long)
If x1 < 0 And x2 < 0 Or x1 >= wp And x2 >= wp _
Or y1 < 0 And y2 < 0 Or y1 >= hLine And y2 >= hLine Then Exit Sub
If x1 < 0 Then x1 = 0
If x2 < 0 Then x2 = 0
If y1 < 0 Then y1 = 0
If y2 < 0 Then y2 = 0
If x1 >= wb Then x1 = wb - 1
If x2 >= wb Then x2 = wb - 1
If y1 >= hLine Then y1 = hLine - 1
If y2 >= hLine Then y2 = hLine - 1
vLine_ x1, x2, y1, color
vLine_ x1, x2, y2, color
hLine_ x1, y1, y2, color
hLine_ x2, y1, y2, color
End Sub
Public Sub fillRectangle(x1 As Long, y1 As Long, x2 As Long, y2 As Long, color As Long)
If x1 < 0 And x2 < 0 Or x1 >= wp And x2 >= wp _
Or y1 < 0 And y2 < 0 Or y1 >= hLine And y2 >= hLine Then Exit Sub
If x1 < 0 Then x1 = 0
If x2 < 0 Then x2 = 0
If y1 < 0 Then y1 = 0
If y2 < 0 Then y2 = 0
If x1 >= wb Then x1 = wb - 1
If x2 >= wb Then x2 = wb - 1
If y1 >= hLine Then y1 = hLine - 1
If y2 >= hLine Then y2 = hLine - 1
Dim x As Long, y As Long, ob As Long, kx As Long, ky As Long
kx = IIf(x1 < x2, 1, -1)
ky = IIf(y1 < y2, 1, -1)
ob = y1 * wb + x1
For y = y1 To y2 Step ky
For x = x1 To x2 Step kx
byteBmp(ob + x) = color
Next
ob = ob + wb * ky
Next
End Sub
Public Sub cre(x As Long, y As Long, r As Long, color As Long)
Dim xx As Long, yy As Long, f As Long
xx = 0
yy = r
setpixel x + xx, y + yy, color
setpixel x + xx, y - yy, color
setpixel x + yy, y + xx, color
setpixel x - yy, y + xx, color
f = 3 - r + r
Do While 1
If f < 0 Then
f = f + xx * 4 + 6
Else
f = f + (xx - yy) * 4 + 10
yy = yy - 1
End If
xx = xx + 1
If xx = yy Then
setpixel x + xx, y + yy, color
setpixel x - xx, y - yy, color
setpixel x + xx, y - yy, color
setpixel x - xx, y + yy, color
Exit Do
ElseIf xx < yy Then
setpixel x + xx, y + yy, color
setpixel x + xx, y - yy, color
setpixel x - xx, y + yy, color
setpixel x - xx, y - yy, color
setpixel x + yy, y + xx, color
setpixel x + yy, y - xx, color
setpixel x - yy, y + xx, color
setpixel x - yy, y - xx, color
Else
Exit Do
End If
Loop
End Sub
Public Sub fillCre(x As Long, y As Long, r As Long, color As Long)
Dim xx As Long, yy As Long, f As Long
xx = 0
yy = r
setpixel x + xx, y + yy, color
setpixel x + xx, y - yy, color
vLine x + yy, x - yy, y + xx, color
f = 3 - r + r
Do While 1
If f < 0 Then
f = f + xx * 4 + 6
Else
f = f + (xx - yy) * 4 + 10
yy = yy - 1
End If
xx = xx + 1
If xx = yy Then
vLine x + xx, x - xx, y + yy, color
vLine x + xx, x - xx, y - yy, color
Exit Do
ElseIf xx < yy Then
vLine x + xx, x - xx, y + yy, color
vLine x + xx, x - xx, y - yy, color
vLine x + yy, x - yy, y + xx, color
vLine x + yy, x - yy, y - xx, color
Else
Exit Do
End If
Loop
End Sub
Public Sub clsBmp8()
Dim i As Long
For i = 0 To wb * hLine - 1
byteBmp(i) = 0
Next
End Sub
Public Sub transmitBmp8(hDC As Long, x As Long, y As Long)
StretchDIBits hDC, x, y, wp, hp, 0, 0, wp, hp, bytePtr, infoPtr, DIB_RGB_COLORS, SRCCOPY
End Sub
Private Sub Class_Terminate()
Erase byteBmp
Erase bi
End Sub
2022-09-01 10:02
vbd.rar