Ejemplos usando el Api de windows para Visual basic

59 - Graduar el brillo a un gráfico o imagen en controles Picturebox y formularios

Este muy buen ejemplo publicado por Crítico del canalVisualBasic y retocado por Leandro Ascierto, permite aplicar y graduar el brillo en imagenes cargadas en un PictureBox o formularios. El módulo bas tiene una función llamada EstablecerBrillo. Este tiene 2 parámetros, la primera se le debe enviar el formulario o PictureBox, y la segunda es el valor de la intensidad del brillo, que puede ser un número entre -255 y 255.

Hay que aclarar que el ejemplo, le aplica el efecto a todo el área de la ventana, es decir no solo al gráfico. Por lo tanto en los controles pictureBox, se puede solucionar poniendo el mismo con la propiedad AutoSize en True. Si no otra forma que se me está ocurriendo ahora, pero no la probé, es agregarle algunas líneas de código para que solo le aplique el efecto a las dimensiones que tenga el gráfico, abría que modificar que tome como área, no la totalidad de las dimensiones del Picture o Form si no las del gráfico cargado. Para eso abría que obtener prviamente las dimensiones de la imagen y la posición de la misma si es que está dibujada con los métodos gráficos, y luego usar esos valores para aplicarlos a dicha área.

Ejemplo

El ejemplo siguiente es mediante un PictureBox, entonces colocar :

Un Picture1, cargarle una imagen
Agregar una barra de scroll horizontal.

Código en un formulario:

Private Sub Form_Load() HScroll1.Value = 0 HScroll1.Min = -255 HScroll1.Max = 255 'Opcional Picture1.AutoSize = True End Sub Private Sub HScroll1_Change() 'Le pasamos como parámetro l PictureBox y el valor _ de la intensidad del brillo EstablecerBrillo Picture1, HScroll1 End Sub

Código en un módulo bas:

Option Explicit ' (DWORD) dest = origen Public Const SRCCOPY = &HCC0020 'tabla de color en RGB (rojo-verde-azul) Public Const DIB_RGB_COLORS = 0 Public Const BI_RGB = 0& 'Estructuras '******************************** Public Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End Type Public Type 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 Public Type BITMAPINFO24 bmiHeader As BITMAPINFOHEADER bmiColors() As RGBQUAD End Type Private Type SAFEARRAYBOUND cElements As Long lLbound As Long End Type Private Type SAFEARRAY2D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long Bounds(0 To 1) As SAFEARRAYBOUND End Type 'Declaración de Funciones Api '****************************************************** Public Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, _ pBitmapInfo As BITMAPINFO24, ByVal un As Long, lplpVoid As Long, ByVal _ handle As Long, ByVal dw As Long) As Long Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _ ByVal hDC As Long) As Long Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, _ ByVal hObject As Long) As Long Public 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 Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As _ Any, Source As Any, ByVal Length As Long) Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long 'Fucnión que establece el brillo. Obj es un formulario o un PictureBox 'La intensidad del brillo puede ser un valor desde -255 hasta 255 Public Sub EstablecerBrillo(obj As Object, Intensidad As Integer) Dim BytesPerLine As Long Dim WinDC As Long Dim TmpDC As Long Dim dl As Long Dim mBmp As Long Dim AntBmp As Long Dim Addrs As Long Dim ContadorX As Long Dim ContadorY As Long Dim lpBits() As Byte Dim mSizeImage As Long Dim Rojo As Long, Verde As Long, Azul As Long, Gris As Long Dim M_BitmapInfo As BITMAPINFO24 Dim SA As SAFEARRAY2D Screen.MousePointer = 11 If TypeOf obj Is PictureBox Then 'solo para refrescar a la imagen original en los Picturebox obj = obj End If obj.ScaleMode = 3 obj.AutoRedraw = True BytesPerLine = ScanAlign(obj.ScaleWidth * 3) mSizeImage = BytesPerLine * obj.ScaleHeight With M_BitmapInfo.bmiHeader .biSize = Len(M_BitmapInfo.bmiHeader) .biWidth = obj.ScaleWidth .biHeight = obj.ScaleHeight .biPlanes = 1 .biBitCount = 24 .biCompression = BI_RGB .biSizeImage = mSizeImage End With WinDC = GetDC(0) TmpDC = CreateCompatibleDC(WinDC) mBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0) dl = ReleaseDC(0, WinDC) With SA .cbElements = 1 .cDims = 2 .Bounds(0).lLbound = 0 .Bounds(0).cElements = obj.ScaleHeight .Bounds(1).lLbound = 0 .Bounds(1).cElements = BytesPerLine .pvData = Addrs End With CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4 AntBmp = SelectObject(TmpDC, mBmp) 'Se copia el gráfico a un hdc temporal dl = BitBlt(TmpDC, 0, 0, obj.ScaleWidth, obj.ScaleHeight, _ obj.hDC, 0, 0, SRCCOPY) For ContadorY = 0 To obj.ScaleHeight - 1 For ContadorX = 0 To (obj.ScaleWidth * 3) - 1 Step 3 Azul = lpBits(ContadorX + 2, ContadorY) Verde = lpBits(ContadorX + 1, ContadorY) Rojo = lpBits(ContadorX, ContadorY) Azul = Azul + Intensidad If Azul > 255 Then Azul = 255 If Azul < 0 Then Azul = 0 Verde = Verde + Intensidad If Verde > 255 Then Verde = 255 If Verde < 0 Then Verde = 0 Rojo = Rojo + Intensidad If Rojo > 255 Then Rojo = 255 If Rojo < 0 Then Rojo = 0 lpBits(ContadorX, ContadorY) = Rojo lpBits(ContadorX + 1, ContadorY) = Verde lpBits(ContadorX + 2, ContadorY) = Azul Next ContadorX Next ContadorY CopyMemory ByVal VarPtrArray(lpBits), 0&, 4 dl = BitBlt(obj.hDC, 0, 0, obj.ScaleWidth, obj.ScaleHeight, _ TmpDC, 0, 0, SRCCOPY) dl = SelectObject(TmpDC, AntBmp) dl = DeleteObject(mBmp) dl = DeleteDC(TmpDC) obj.Refresh Screen.MousePointer = 0 End Sub Private Function ScanAlign(WidthBmp As Long) As Long ScanAlign = (WidthBmp + 3) And &HFFFFFFFC End Function

Buscar en Recursos vb