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

解决方案 »

  1.   

    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 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
      

  2.   

    以下是原代码,没问题,不过... ...
    '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
      

  3.   

    先去掉中间处理颜色的部分就是双重for循环的那段, 直接把输入数据输出看看有没有问题.
      

  4.   


    去掉for循环试过,原图没变,没问题。这并不代表调整后的图也不会变。
      

  5.   


    去掉for循环试过,原图没变,没问题。这并不代表调整后的图也不会变。这只是调式程序的一个步骤而已, 缩小问题的范围呀.