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 Long
Private 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 Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private 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
uj5u.com熱心網友回復：
Private Sub Form_Load()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 Sub
Public 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 Sub
Public 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 Sub
Private 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 Function
Private 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
uj5u.com熱心網友回復：
以下是原代碼，沒問題，不過... ...'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
uj5u.com熱心網友回復：
先去掉中間處理顏色的部分就是雙重for回圈的那段, 直接把輸入資料輸出看看有沒有問題.uj5u.com熱心網友回復：
去掉for回圈試過，原圖沒變，沒問題。這并不代表調整后的圖也不會變。
uj5u.com熱心網友回復：
這只是調式程式的一個步驟而已, 縮小問題的范圍呀.
uj5u.com熱心網友回復：
你把原始碼放全了，才好除錯，幫忙找原因呢。轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/109528.html
標籤：多媒體