|
#2
jklqwe1112022-09-01 10:03
类模块代码 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 |
只有本站会员才能查看附件，请 登录
