Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFOHEADER, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw 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
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As LongPrivate Type BITMAPINFOHEADER 'BITMAP的文件头结构
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 TypePrivate Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End TypePrivate Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End TypePrivate Type RGB_DATA
'A As Byte
B As Byte
G As Byte
R As Byte
End Type
Sub AdjustHSL(pSrc As PictureBox, pDes As PictureBox, Hue As Long, Saturation As Long, _
Optional srcX As Long, _
Optional srcY As Long, _
Optional SrcW As Long, _
Optional SrcH As Long)
'On Error Resume Next
Dim R As Byte, G As Byte, B As Byte, A As Byte, H As Single, S As Single, L As Single
Dim dH As Long, dS As Long, X As Long, Y As Long Dim MyhDC As Long
Dim MyBMIH As BITMAPINFOHEADER
Dim MyhDIB As Long
Dim MyPtr As Long
Dim hOldMap As Long
Dim MapData() As Byte
Dim MaxI As Long
Dim IRGB() As RGB_DATA
Dim ISize As Long
Dim bi As BITMAPINFO
If SrcW = 0 Then SrcW = pSrc.ScaleWidth
If SrcH = 0 Then SrcH = pSrc.ScaleHeight With MyBMIH
.biSize = 40
.biWidth = SrcW
.biHeight = SrcH
.biPlanes = 1
.biBitCount = 24
.biSizeImage = (.biWidth * (.biBitCount / 8)) * .biHeight
End With
bi.bmiHeader = MyBMIH
ISize = MyBMIH.biSizeImage
MyhDC = CreateCompatibleDC(0)
MyhDIB = CreateDIBSection(MyhDC, MyBMIH, 0, MyPtr, 0, 0)
'Debug.Print "MyhDIB="; MyhDIB
If MyhDIB = 0 Then DeleteObject MyhDC: Exit Sub hOldMap = SelectObject(MyhDC, MyhDIB)
BitBlt MyhDC, 0, 0, SrcW, SrcH, pSrc.hdc, srcX, srcY, vbSrcCopy
ReDim IRGB(0 To SrcW - 1, 0 To SrcH - 1)
Call GetBitmapBits(MyhDIB, ISize, IRGB(0, 0))
'GetDIBits MyhDC, MyhDIB, 0, SrcH, IRGB(0, 0), bi, 0
For Y = 0 To SrcH - 1
For X = 0 To SrcW - 1
RGBtoHSL IRGB(X, Y).R, IRGB(X, Y).G, IRGB(X, Y).B, H, S, L
dH = H + Hue / 30
If dH < -1 Then dH = dH + 6 Else If dH > 5 Then dH = dH - 6
S = S + Saturation / 100
If S > 1 Then S = 1 Else If S < 0 Then S = 0
HSLtoRGB dH, S, L, IRGB(X, Y).R, IRGB(X, Y).G, IRGB(X, Y).B
Next X
Next Y
Call SetBitmapBits(MyhDIB, MyBMIH.biSizeImage, IRGB(0, 0))
'SetDIBits MyhDC, MyhDIB, 0, SrcH, IRGB(0, 0), bi, 0
BitBlt pDes.hdc, srcX, srcY, SrcW, SrcH, MyhDC, 0, 0, vbSrcCopy
If hOldMap Then DeleteObject SelectObject(MyhDC, hOldMap)
DeleteObject MyhDIB
DeleteObject MyhDC
Erase MapData
pDes.Refresh
End Sub
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFOHEADER, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw 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
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As LongPrivate Type BITMAPINFOHEADER 'BITMAP的文件头结构
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 TypePrivate Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End TypePrivate Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End TypePrivate Type RGB_DATA
'A As Byte
B As Byte
G As Byte
R As Byte
End Type
Sub AdjustHSL(pSrc As PictureBox, pDes As PictureBox, Hue As Long, Saturation As Long, _
Optional srcX As Long, _
Optional srcY As Long, _
Optional SrcW As Long, _
Optional SrcH As Long)
'On Error Resume Next
Dim R As Byte, G As Byte, B As Byte, A As Byte, H As Single, S As Single, L As Single
Dim dH As Long, dS As Long, X As Long, Y As Long Dim MyhDC As Long
Dim MyBMIH As BITMAPINFOHEADER
Dim MyhDIB As Long
Dim MyPtr As Long
Dim hOldMap As Long
Dim MapData() As Byte
Dim MaxI As Long
Dim IRGB() As RGB_DATA
Dim ISize As Long
Dim bi As BITMAPINFO
If SrcW = 0 Then SrcW = pSrc.ScaleWidth
If SrcH = 0 Then SrcH = pSrc.ScaleHeight With MyBMIH
.biSize = 40
.biWidth = SrcW
.biHeight = SrcH
.biPlanes = 1
.biBitCount = 24
.biSizeImage = (.biWidth * (.biBitCount / 8)) * .biHeight
End With
bi.bmiHeader = MyBMIH
ISize = MyBMIH.biSizeImage
MyhDC = CreateCompatibleDC(0)
MyhDIB = CreateDIBSection(MyhDC, MyBMIH, 0, MyPtr, 0, 0)
'Debug.Print "MyhDIB="; MyhDIB
If MyhDIB = 0 Then DeleteObject MyhDC: Exit Sub hOldMap = SelectObject(MyhDC, MyhDIB)
BitBlt MyhDC, 0, 0, SrcW, SrcH, pSrc.hdc, srcX, srcY, vbSrcCopy
ReDim IRGB(0 To SrcW - 1, 0 To SrcH - 1)
Call GetBitmapBits(MyhDIB, ISize, IRGB(0, 0))
'GetDIBits MyhDC, MyhDIB, 0, SrcH, IRGB(0, 0), bi, 0
For Y = 0 To SrcH - 1
For X = 0 To SrcW - 1
RGBtoHSL IRGB(X, Y).R, IRGB(X, Y).G, IRGB(X, Y).B, H, S, L
dH = H + Hue / 30
If dH < -1 Then dH = dH + 6 Else If dH > 5 Then dH = dH - 6
S = S + Saturation / 100
If S > 1 Then S = 1 Else If S < 0 Then S = 0
HSLtoRGB dH, S, L, IRGB(X, Y).R, IRGB(X, Y).G, IRGB(X, Y).B
Next X
Next Y
Call SetBitmapBits(MyhDIB, MyBMIH.biSizeImage, IRGB(0, 0))
'SetDIBits MyhDC, MyhDIB, 0, SrcH, IRGB(0, 0), bi, 0
BitBlt pDes.hdc, srcX, srcY, SrcW, SrcH, MyhDC, 0, 0, vbSrcCopy
If hOldMap Then DeleteObject SelectObject(MyhDC, hOldMap)
DeleteObject MyhDIB
DeleteObject MyhDC
Erase MapData
pDes.Refresh
End Sub
pDes.Width = Picture1.Width
pDes.Height = Picture1.Height
pDes.PaintPicture Picture1.Image, 0, 0
pSrc.Width = pDes.Width
pSrc.Height = pDes.Height
pSrc.PaintPicture Picture1.Image, 0, 0
End SubPublic Sub RGBtoHSL(ByVal R As Byte, ByVal G As Byte, ByVal B As Byte, H As Single, S As Single, L As Single)
Dim Max As Single
Dim Min As Single
Dim delta As Single
Dim rR As Single, rG As Single, rB As Single '-- Given: RGB each in [0,1]
'-- Desired: H in [0,240] and S in [0,1], except if S = 0, then H = UNDEFINED
rR = R / 255: rG = G / 255: rB = B / 255
Max = pvMaximum(rR, rG, rB)
Min = pvMinimum(rR, rG, rB)
L = (Max + Min) / 2
'== Calculate saturation:
'-- Achromatic case
If (Max = Min) Then
S = 0
H = 0
'-- Chromatic case
Else
'-- First calculate the saturation
If (L <= 0.5) Then
S = (Max - Min) / (Max + Min)
Else
S = (Max - Min) / (2 - Max - Min)
End If
'-- Next calculate the hue
delta = Max - Min
If (rR = Max) Then
H = (rG - rB) / delta ' Resulting color is between yellow and magenta
ElseIf (rG = Max) Then
H = 2 + (rB - rR) / delta ' Resulting color is between cyan and yellow
ElseIf (rB = Max) Then
H = 4 + (rR - rG) / delta ' Resulting color is between magenta and cyan
End If
End If
End SubPublic Sub HSLtoRGB(ByVal H As Single, ByVal S As Single, ByVal L As Single, R As Byte, G As Byte, B As Byte)
Dim rR As Single, rG As Single, rB As Single
Dim Min As Single, Max As Single '-- Achromatic case:
If (S = 0) Then
rR = L: rG = L: rB = L
'-- Chromatic case:
Else
If (L <= 0.5) Then
'-- S = (Max - Min) / (Max + Min)
Min = L * (1 - S)
Else
'-- S = (Max - Min) / (2 - Max - Min)
Min = L - S * (1 - L)
End If
Max = 2 * L - Min
'-- Now depending on sector we can evaluate the H,L,S:
If (H < 1) Then
rR = Max
If (H < 0) Then
rG = Min
rB = rG - H * (Max - Min)
Else
rB = Min
rG = H * (Max - Min) + rB
End If
ElseIf (H < 3) Then
rG = Max
If (H < 2) Then
rB = Min
rR = rB - (H - 2) * (Max - Min)
Else
rR = Min
rB = (H - 2) * (Max - Min) + rR
End If
Else
rB = Max
If (H < 4) Then
rR = Min
rG = rR - (H - 4) * (Max - Min)
Else
rG = Min
rR = (H - 4) * (Max - Min) + rG
End If
End If
End If
R = rR * 255: G = rG * 255: B = rB * 255
End SubPrivate Function pvMaximum(rR As Single, rG As Single, rB As Single) As Single
If (rR > rG) Then
If (rR > rB) Then pvMaximum = rR Else pvMaximum = rB
Else
If (rB > rG) Then pvMaximum = rB Else pvMaximum = rG
End If
End FunctionPrivate Function pvMinimum(rR As Single, rG As Single, rB As Single) As Single
If (rR < rG) Then
If (rR < rB) Then pvMinimum = rR Else pvMinimum = rB
Else
If (rB < rG) Then pvMinimum = rB Else pvMinimum = rG
End If
End Function'//Public Function RotateH40(ByVal H As Long) As Long
'-- Rotate Hue ->[Red...Red]
If (H > 200) Then RotateH40 = H - 240 Else RotateH40 = H
End Function
'Sub AdjustHSL()
' Dim x As Long
' Dim y As Long
' Dim Color As Long
' Dim R As Byte, G As Byte, B As Byte
' Dim H As Single, S As Single, L As Single
' Dim pH As Single, DesH As Single, DesS As Single
' pH = HScroll1.Value / 30
' DesS = HScroll2.Value
' For y = 0 To Picture1.ScaleHeight - 1
' For x = 0 To Picture1.ScaleWidth - 1
' Color = GetPixel(Picture1.hdc, x, y)
' R = Color Mod 256 'Color And &HFF
' G = (Color Mod 65536) \ 256 '(Color And &HFF00&) / &H100&
' B = Color \ 65536 'Color And &HFF0000 / &H10000
' RGBtoHSL R, G, B, H, S, L
' DesH = H + pH
' If DesH < -1 Then DesH = DesH + 6 Else If DesH > 5 Then DesH = DesH - 6
' S = S + DesS / 100
' If S > 1 Then S = 1 Else If S < 0 Then S = 0
' HSLtoRGB DesH, S, L, R, G, B
' SetPixel Picture2.hdc, x, y, RGB(R, G, B)
' Next x
' Next y
' Picture2.Refresh
' DoEvents
'End Sub
去掉for循环试过,原图没变,没问题。这并不代表调整后的图也不会变。
去掉for循环试过,原图没变,没问题。这并不代表调整后的图也不会变。这只是调式程序的一个步骤而已, 缩小问题的范围呀.