'Option Explicit
這個功能已經實作，需要大家復制代碼，驗證一下改編的HSL是否正確，如何改進。
'控制元件：picture 1 裝載源圖片
' picture2 空，無圖片
' picture3 顯示色相0-360度
' HScroll1 min =0 max=360'色相
' HScroll2 min =0 max=100'飽和度
' HScroll3 min =0 max=100'亮度
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 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 Type BitMapInfoHeader ''檔案資訊頭——BITMAPINFOHEADER
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 RGBQuad
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
''rgbReserved As Byte
End Type
Private Type BitMapInfo
bmiHeader As BitMapInfoHeader
bmiColors As RGBQuad
End Type
Private Sub Form_Load()
Dim W As Long
Dim H As Long
Dim a As Long
Dim i As Long
Dim c As Long
W = Picture3.Width '寬度
H = Picture3.Height '高度
a = W / 6 '影像分六部分
For i = 0 To a
c = i * 255 / a
Picture3.Line (i + a * 0, 0)-(i + a * 0, H), RGB(255, c, 0)
Picture3.Line (i + a * 1, 0)-(i + a * 1, H), RGB(255 - c, 255, 0)
Picture3.Line (i + a * 2, 0)-(i + a * 2, H), RGB(0, 255, c)
Picture3.Line (i + a * 3, 0)-(i + a * 3, H), RGB(0, 255 - c, 255)
Picture3.Line (i + a * 4, 0)-(i + a * 4, H), RGB(c, 0, 255)
Picture3.Line (i + a * 5, 0)-(i + a * 5, H), RGB(255, 0, 255 - c)
Next i
For i = 0 To 6
If i <> 6 Then
Picture3.CurrentX = i * a - TextWidth(i * 60) / 2
Else
Picture3.CurrentX = W - TextWidth("36000")
End If
Picture3.CurrentY = H / 2 - TextHeight(i)
Picture3.Print i * 60
Next
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)
On Error Resume Next
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
If R > 255 Then R = 255
If G > 255 Then G = 255
If B > 255 Then B = 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
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, DesL As Single
pH = HScroll1.Value / 30
DesS = HScroll2.Value
DesL = HScroll3.Value
Dim ix As Integer
Dim iy As Integer
Dim iWidth As Integer '以像素為單位的圖形寬度
Dim iHeight As Integer '以像素為單位的圖形高度
Dim bits() As Byte '三維陣列，用于獲取原彩色影像中各像素的RGB數值以及存放轉化后的灰度值
Dim bitsBW() As Byte '三維陣列，用于存放轉化為黑白圖后各像素的值
'獲取圖形的寬度和高度
iWidth = Picture1.ScaleWidth / Screen.TwipsPerPixelX
iHeight = Picture1.ScaleHeight / Screen.TwipsPerPixelY
Picture1.Picture = Picture1.Image
'創建并初始化一個bitMapInfo自定義型別
Dim bi24BitInfo As BitMapInfo
With bi24BitInfo.bmiHeader
.biBitCount = 32
.biCompression = 0&
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = iWidth
.biHeight = Picture1.ScaleHeight / Screen.TwipsPerPixelY
End With
'重新定義陣列大小
ReDim bits(3, 0 To iWidth, 0 To iHeight) As Byte
ReDim bitsBW(3, 0 To iWidth, 0 To iHeight) As Byte
'使用GetDIBits方法一次性獲取picture1中各點的rgb值，比point方法或getPixel函式逐像素獲取像素rgb要快出一個數量級
lrtn = GetDIBits(Picture1.hdc, Picture1.Picture.Handle, 0&, iHeight, bits(0, 0, 0), bi24BitInfo, 0&)
'陣列的三個維度分別代表像素的RGB分量、以圖形左下角為原點的X和Y坐標。
'具體說來，這時bits(0,2,3)代表從圖形左下角數起橫向第2個縱向第3個像素的Blue值，而bits(1,2,3)和bits(2,2,3)分別的Green值和Red值.
For ix = 0 To iWidth
For iy = 0 To iHeight
R = bits(0, ix, iy)
G = bits(1, ix, iy)
B = bits(0, ix, iy)
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
L = L + DesL / 100
If L > 1 Then L = 1 Else If L < 0 Then L = 0
HSLtoRGB DesH, S, L, R, G, B
bitsBW(0, ix, iy) = B
bitsBW(1, ix, iy) = G
bitsBW(2, ix, iy) = R
Next
Next
SetDIBits Picture2.hdc, Picture2.Picture.Handle, 0&, iHeight, bitsBW(0, 0, 0), bi24BitInfo, 0&
Picture2.Picture = Picture2.Image
Picture2.Refresh
End Sub
Private Sub HScroll1_Scroll()
Call AdjustHSL
End Sub
Private Sub HScroll2_Scroll()
Call AdjustHSL
End Sub
Private Sub HScroll3_Scroll()
Call AdjustHSL
End Sub
uj5u.com熱心網友回復：
有能力的朋友可以和ps的效果比較一下，看看效果，即如何改進呢？uj5u.com熱心網友回復：
很久沒有用VB了，頂一下吧。轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/109546.html
標籤：多媒體