Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing hDC Functions.bas (7.28 KB)
Attribute VB_Name = "hDC_Functions"
Option Explicit
Type zRGB
R As Long
G As Long
B As Long
End Type
Const GR_UPDOWN As Integer = 0
Const GR_LEFTRIGHT As Integer = 1
Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Function PaintSunburst(hDestDC As Long, ByVal X As Integer, ByVal Y As Integer, ByVal Width As Integer, ByVal Height As Integer, sbColor1 As Long, sbColor2 As Long) As Long
On Error Resume Next
Dim Color1 As zRGB, Color2 As zRGB
Dim X1 As Integer, Y1 As Integer
Dim X2 As Integer, Y2 As Integer
Dim X3 As Integer, Y3 As Integer
Dim RedUnitX, GreenUnitX, BlueUnitX
Dim RedUnitY, GreenUnitY, BlueUnitY
Dim RedValX, GreenValX, BlueValX
Dim RedValY, GreenValY, BlueValY
Dim PixelColor As Long
Dim Retcode As Long
Color1 = LongToRGB(sbColor1)
Color2 = LongToRGB(sbColor2)
RedUnitX = (Color2.R - Color1.R) / (Width / 2)
GreenUnitX = (Color2.G - Color1.G) / (Width / 2)
BlueUnitX = (Color2.B - Color1.B) / (Width / 2)
RedUnitY = (Color2.R - Color1.R) / (Height / 2)
GreenUnitY = (Color2.G - Color1.G) / (Height / 2)
BlueUnitY = (Color2.B - Color1.B) / (Height / 2)
RedValX = Color1.R
GreenValX = Color1.G
BlueValX = Color1.B
RedValY = Color1.R
GreenValY = Color1.G
BlueValY = Color1.B
X3 = Width / 2
X2 = X3
Y2 = 0
For Y1 = (Height / 2) To Y2 Step -1
PixelColor = RGB(RedValY, GreenValY, BlueValY)
For X1 = X3 To X2
Retcode = SetPixel(hDestDC, X + X1, Y + Y1, PixelColor)
Retcode = SetPixel(hDestDC, X + X1, Y + (Height - Y1), PixelColor)
Next X1
X3 = X3 - 1
X2 = X2 + 1
RedValY = RedValY + RedUnitY
GreenValY = GreenValY + GreenUnitY
BlueValY = BlueValY + BlueUnitY
If RedValY < 0 Then RedValY = 0
If RedValY > 255 Then RedValY = 255
If GreenValY < 0 Then GreenValY = 0
If GreenValY > 255 Then GreenValY = 255
If BlueValY < 0 Then BlueValY = 0
If BlueValY > 255 Then BlueValY = 255
Next Y1
Y3 = Height / 2
Y2 = Y3
X2 = Width
For X1 = (Width / 2) To X2
PixelColor = RGB(RedValX, GreenValX, BlueValX)
For Y1 = Y3 To Y2
Retcode = SetPixel(hDestDC, X + X1, Y + Y1, PixelColor)
Retcode = SetPixel(hDestDC, X + (Width - X1), Y + Y1, PixelColor)
Next Y1
Y3 = Y3 - 1
Y2 = Y2 + 1
RedValX = RedValX + RedUnitX
GreenValX = GreenValX + GreenUnitX
BlueValX = BlueValX + BlueUnitX
If RedValX < 0 Then RedValX = 0
If RedValX > 255 Then RedValX = 255
If GreenValX < 0 Then GreenValX = 0
If GreenValX > 255 Then GreenValX = 255
If BlueValX < 0 Then BlueValX = 0
If BlueValX > 255 Then BlueValX = 255
Next X1
If Err Then
PaintSunburst = 0
Else
PaintSunburst = -1
End If
Exit Function
End Function
Function Combine_hDC(ByVal hDC1 As Long, hDC2 As Long, Width As Integer, Height As Integer) As Long
On Error Resume Next
Dim X As Integer, Y As Integer
Dim RedVal, GreenVal, BlueVal
Dim Pixel1 As zRGB
Dim Pixel2 As zRGB
Dim Retcode As Long
For X = 0 To Width - 1
For Y = 0 To Height - 1
Pixel1 = LongToRGB(GetPixel(hDC1, X, Y))
Pixel2 = LongToRGB(GetPixel(hDC2, X, Y))
RedVal = (Pixel2.R - Pixel1.R) / 2
If RedVal < 0 Then RedVal = 0
If RedVal > 255 Then RedVal = 255
GreenVal = (Pixel2.G - Pixel1.G) / 2
If GreenVal < 0 Then GreenVal = 0
If GreenVal > 255 Then GreenVal = 255
BlueVal = (Pixel2.B - Pixel1.B) / 2
If BlueVal < 0 Then BlueVal = 0
If BlueVal > 255 Then BlueVal = 255
Retcode = SetPixel(hDC1, X, Y, _
RGB(Pixel1.R + RedVal, Pixel1.G + GreenVal, Pixel1.B + BlueVal))
Next Y
Next X
Combine_hDC = hDC1
End Function
Function FadePicture(hDestDC As Long, hSrcDC As Long, Width As Integer, Height As Integer, Optional ByVal fTimes As Integer) As Long
On Error Resume Next
Dim X As Integer, Y As Integer
Dim R_FadeUnits(), G_FadeUnits(), B_FadeUnits()
Dim R_Pixel(), G_Pixel(), B_Pixel()
ReDim R_FadeUnits(Width - 1, Height - 1)
ReDim G_FadeUnits(Width - 1, Height - 1)
ReDim B_FadeUnits(Width - 1, Height - 1)
ReDim R_Pixel(Width - 1, Height - 1)
ReDim G_Pixel(Width - 1, Height - 1)
ReDim B_Pixel(Width - 1, Height - 1)
Dim Pixel1 As zRGB
Dim Pixel2 As zRGB
Dim Retcode As Long
If fTimes < 1 Then fTimes = 1
If fTimes > 99 Then fTimes = 99
For X = 0 To Width - 1
For Y = 0 To Height - 1
Pixel1 = LongToRGB(GetPixel(hDestDC, X, Y))
Pixel2 = LongToRGB(GetPixel(hSrcDC, X, Y))
R_FadeUnits(X, Y) = (Pixel2.R - Pixel1.R) / fTimes
G_FadeUnits(X, Y) = (Pixel2.G - Pixel1.G) / fTimes
B_FadeUnits(X, Y) = (Pixel2.B - Pixel1.B) / fTimes
R_Pixel(X, Y) = Pixel1.R
G_Pixel(X, Y) = Pixel1.G
B_Pixel(X, Y) = Pixel1.B
Next Y
Next X
For fTimes = fTimes To 1 Step -1
For X = 0 To Width - 1
For Y = 0 To Height - 1
R_Pixel(X, Y) = R_Pixel(X, Y) + R_FadeUnits(X, Y)
If R_Pixel(X, Y) < 0 Then R_Pixel(X, Y) = 0
If R_Pixel(X, Y) > 255 Then R_Pixel(X, Y) = 255
G_Pixel(X, Y) = G_Pixel(X, Y) + G_FadeUnits(X, Y)
If G_Pixel(X, Y) < 0 Then G_Pixel(X, Y) = 0
If G_Pixel(X, Y) > 255 Then G_Pixel(X, Y) = 255
B_Pixel(X, Y) = B_Pixel(X, Y) + B_FadeUnits(X, Y)
If B_Pixel(X, Y) < 0 Then B_Pixel(X, Y) = 0
If B_Pixel(X, Y) > 255 Then B_Pixel(X, Y) = 255
Retcode = SetPixel(hDestDC, X, Y, _
RGB(R_Pixel(X, Y), G_Pixel(X, Y), B_Pixel(X, Y)))
Next Y
Next X
DoEvents
Next fTimes
If Err Then
FadePicture = 0
Else
FadePicture = -1
End If
End Function
Function LongToRGB(ByVal crColor As Long) As zRGB
Const R As Long = 1
Const G As Long = 256
Const B As Long = 65536
LongToRGB.B = crColor \ B
crColor = crColor Mod B
If LongToRGB.B < 0 Then LongToRGB.B = 0
LongToRGB.G = crColor \ G
crColor = crColor Mod G
If LongToRGB.G < 0 Then LongToRGB.G = 0
LongToRGB.R = crColor \ R
crColor = crColor Mod R
If LongToRGB.R < 0 Then LongToRGB.R = 0
End Function
Function PaintGradient(hDestDC As Long, ByVal X As Integer, ByVal Y As Integer, ByVal Width As Integer, ByVal Height As Integer, grColor1 As Long, grColor2 As Long, Optional grType As Integer) As Long
On Error Resume Next
Dim Color1 As zRGB, Color2 As zRGB
Dim X1 As Integer, Y1 As Integer
Dim X2 As Integer, Y2 As Integer
Dim RedUnit, GreenUnit, BlueUnit
Dim RedVal, GreenVal, BlueVal
Dim PixelColor As Long
Dim grUnit As Integer
Dim Retcode As Long
If grType = 0 Then
grUnit = Height
Else
grUnit = Width
End If
Color1 = LongToRGB(grColor1)
Color2 = LongToRGB(grColor2)
RedUnit = (Color2.R - Color1.R) / grUnit
GreenUnit = (Color2.G - Color1.G) / grUnit
BlueUnit = (Color2.B - Color1.B) / grUnit
RedVal = Color1.R
GreenVal = Color1.G
BlueVal = Color1.B
Select Case grType
Case 0
Y2 = Y + Height - 1
X2 = X + Width - 1
For Y1 = Y To Y2
PixelColor = RGB(RedVal, GreenVal, BlueVal)
For X1 = X To X2
Retcode = SetPixel(hDestDC, X1, Y1, PixelColor)
Next X1
GoSub SetNextColor
Next Y1
Case 1
X2 = X + Width - 1
Y2 = Y + Height - 1
For X1 = X To X2
PixelColor = RGB(RedVal, GreenVal, BlueVal)
For Y1 = Y To Y2
Retcode = SetPixel(hDestDC, X1, Y1, PixelColor)
Next Y1
GoSub SetNextColor
Next X1
End Select
If Err Then
PaintGradient = 0
Else
PaintGradient = -1
End If
Exit Function
SetNextColor:
RedVal = RedVal + RedUnit
GreenVal = GreenVal + GreenUnit
BlueVal = BlueVal + BlueUnit
If RedVal < 0 Then RedVal = 0
If RedVal > 255 Then RedVal = 255
If GreenVal < 0 Then GreenVal = 0
If GreenVal > 255 Then GreenVal = 255
If BlueVal < 0 Then BlueVal = 0
If BlueVal > 255 Then BlueVal = 255
Return
End Function