Gráficos – Leandro Ascierto

Neumorphism Design

Controles de Usuarios, Gráficos, Módulos 4 Responses »

Mar 182021

En este caso se trata por un lado de un Módulo clase y por otro un Usercontrol para crear una interfaz de usuario moderna llamada Neumorphism o Neomorfismo, la cual comenzó a ponerse de moda a partir del 2020, si bien está pensada para aplicaciones móviles o webs no veo motivo para no implementarlo en nuestro querido vb6, al menos en aplicaciones pequeñas para no sobrecargar mucho la memoria y ralentizar nuestra app. El motor de todo esta basado en GDI+.

Con el módulo clase hay un ejemplo donde podemos jugar con las propiedades de la clase y otro formularios con algunos ejemplos graficados.
Además este permite dibujar un Path de GDI+ con el cual se utilizó un módulo extra, donde se puede crear distintas formas (Shapes) y se les puede aplicar el estilo, aprovecho para agradecer a Eduardo por tomar parte de las rutinas de su ShapeEx.

Con el Usercontrol hay tres ejemplos aplicados. No voy a detallar todas las propiedades, es cuestión de meter mano y jugar un poco, son las mismas del módulo. Con los ejemplos esta acompañando el usercontrol «LabelPlus» que es para agregar texto e iconos a las formas, (no quise volver a programar todo esto por eso utilicé dos usercontrols).

Ya más adelante voy a subir un reproductor de música en el que estoy trabajando donde puede verse todo esto aplicado.

Por último quiero aclarar que todo esto funciona más rápido cuando está compilado..

Esferas con GDI+

Gráficos No Responses »

Abr 272010

Esta es una función para dibujar esferas utilizando GDI+. Existen varios diseños, yo elegí este, el cual está conformado con un color gradient central, una luz que la enfoca por encima y una sombra del mismo color que la esfera.
Es muy entretenido jugar con los métodos gráficos de GDI+ ya que nos permite utilizar transparencias, anti-alias y muchas funciones con las cuales podríamos hacer gráficos tal como en Photo Shop.

Esferas

[code lang=»vb»]

Option Explicit

‘ ————————————————————
‘ Autor: Leandro I. Ascierto
‘ Fecha: 27 de Abril de 2010
‘ Web: www.leandroascierto.com.ar
‘ ————————————————————

Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mSmoothingMode As Long) As Long
Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
Private Declare Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GdipCreatePath Lib "GdiPlus.dll" (ByVal mBrushMode As Long, ByRef mPath As Long) As Long
Private Declare Function GdipDeletePath Lib "GdiPlus.dll" (ByVal mPath As Long) As Long
Private Declare Function GdipCreateLineBrushFromRectI Lib "GdiPlus.dll" (ByRef mRect As RECTL, ByVal mColor1 As Long, ByVal mColor2 As Long, ByVal mMode As LinearGradientMode, ByVal mWrapMode As WrapMode, ByRef mLineGradient As Long) As Long
Private Declare Function GdipAddPathEllipseI Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipSetPathGradientCenterColor Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mColors As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "GdiPlus.dll" (ByVal mBrush As Long, ByRef mColor As Long, ByRef mCount As Long) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "GdiPlus.dll" (ByVal mPath As Long, ByRef mPolyGradient As Long) As Long
Private Declare Function GdipSetLinePresetBlend Lib "GdiPlus.dll" (ByVal mBrush As Long, ByRef mBlend As Long, ByRef mPositions As Single, ByVal mCount As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long

Private Type RECTL
Left As Long
Top As Long
Width As Long
Height As Long
End Type

Private Enum LinearGradientMode
LinearGradientModeHorizontal = &H0
LinearGradientModeVertical = &H1
LinearGradientModeForwardDiagonal = &H2
LinearGradientModeBackwardDiagonal = &H3
End Enum

Private Enum WrapMode
WrapModeTile = &H0
WrapModeTileFlipX = &H1
WrapModeTileFlipy = &H2
WrapModeTileFlipXY = &H3
WrapModeClamp = &H4
End Enum

Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type

Private Const SmoothingModeAntiAlias As Long = &H4
Dim GdipToken As Long

Private Sub Form_Load()
Call InitGDI
Me.AutoRedraw = True
DrawSphere Me.hdc, vbBlue, 10, 20, 150, 150
DrawSphere Me.hdc, vbGreen, 180, 20, 150, 150
DrawSphere Me.hdc, vbRed, 350, 20, 150, 150
DrawSphere Me.hdc, vbYellow, 10, 210, 150, 150
DrawSphere Me.hdc, vbBlack, 180, 210, 150, 150
DrawSphere Me.hdc, vbMagenta, 350, 210, 150, 150
DrawSphere Me.hdc, vbCyan, 10, 400, 150, 150
DrawSphere Me.hdc, vbWhite, 180, 400, 150, 150
DrawSphere Me.hdc, &H99FF&, 350, 400, 150, 150
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call TerminateGDI
End Sub

Public Function DrawSphere(ByVal hdc As Long, _
ByVal lColor As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal Width As Long, _
ByVal Height As Long, _
Optional ByVal bDrawShadow As Boolean = True, _
Optional ByVal lAlpha As Long = 100) As Boolean

Dim hGraphics As Long
Dim hBrush As Long
Dim mPath As Long
Dim mRect As RECTL
Dim col(2) As Long
Dim pos(2) As Single

‘crea un grafico a partir de un hdc
If GdipCreateFromHDC(hdc, hGraphics) = 0 Then

‘aplica el modo antialias
Call GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)

‘ —————————– Shadow ————————————-
If bDrawShadow Then

Call GdipCreatePath(&H0, mPath) ‘Crea un Path
GdipAddPathEllipseI mPath, X, Y + Height / 1.1, Width, Height / 4 ‘Dibuja un Circulo
GdipCreatePathGradientFromPath mPath, hBrush ‘Crea una brocha a partir de el Path

GdipSetPathGradientCenterColor hBrush, ConvertColor(lColor, lAlpha / 3) ‘Asigna un color central a la brocha
GdipSetPathGradientSurroundColorsWithCount hBrush, 0, 1 ‘Aplica un color Transparente al contorno de la brocha/circulo

Call GdipFillEllipseI(hGraphics, hBrush, X, Y + Height / 1.1, Width, Height / 4) ‘dibuja la sombra en el grafico

Call GdipDeleteBrush(hBrush) ‘Descarga la brocha
Call GdipDeletePath(mPath) ‘Descarga el Path
End If

‘—————————– Sphere ————————————-

Call GdipCreatePath(&H0, mPath) ‘Crea un Path

GdipAddPathEllipseI mPath, X – (Width / 1.75), Y – Height / 2, Width * 2, Height * 2 ‘Dibuja un Circulo en el path
GdipCreatePathGradientFromPath mPath, hBrush ‘Crea una brocha a partir de el Path
GdipSetPathGradientCenterColor hBrush, ConvertColor(lColor, lAlpha) ‘Asigna el color central a la brocha
GdipSetPathGradientSurroundColorsWithCount hBrush, ConvertColor(ShiftColor(lColor, vbBlack, 100), lAlpha), 1 ‘Aplica un color mas opaco al gradient de la brocha

Call GdipFillEllipseI(hGraphics, hBrush, X, Y, Width, Height) ‘Dibuja un circulo en el grafico
Call GdipDeleteBrush(hBrush) ‘Descarga la brocha
Call GdipDeletePath(mPath) ‘Descarga el Path

‘—————————– Light ————————————-

mRect.Left = X + Width / 10
mRect.Top = Y + Height / 50
mRect.Width = Width – Width / 5
mRect.Height = Height / 1.5

GdipCreateLineBrushFromRectI mRect, 0, 0, LinearGradientModeVertical, WrapModeTileFlipy, hBrush ‘crea una brocha de dos colores

col(0) = ConvertColor(vbWhite, lAlpha / 1.25) ‘Primer color
col(1) = 0 ‘segundo color transparente
col(2) = 0 ‘tercer color transparente

pos(0) = 0
pos(1) = 0.6 ‘El 60% de la brocha va a ser transparente
pos(2) = 1

Call GdipSetLinePresetBlend(hBrush, col(0), pos(0), 3) ‘Asigna los valores para la brocha
Call GdipFillEllipseI(hGraphics, hBrush, mRect.Left, mRect.Top, mRect.Width, mRect.Height – 1) ‘dibuja un circulo aplastado semi transparente
Call GdipDeleteBrush(hBrush) ‘Elimina la brocha

‘ ————————————————————————

Call GdipDeleteGraphics(hGraphics) ‘Elimina el grafico.
End If

End Function

‘ funcion para convertir un color long a un BGRA(Blue, Green, Red, Alpha)
Private Function ConvertColor(Color As Long, Opacity As Long) As Long
Dim BGRA(0 To 3) As Byte

BGRA(3) = CByte((Abs(Opacity) / 100) * 255)
BGRA(0) = ((Color \ &H10000) And &HFF)
BGRA(1) = ((Color \ &H100) And &HFF)
BGRA(2) = (Color And &HFF)
CopyMemory ConvertColor, BGRA(0), 4&
End Function

‘Funcion para combinar dos colores
Private Function ShiftColor(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long

Dim clrFore(3) As Byte
Dim clrBack(3) As Byte

OleTranslateColor clrFirst, 0, VarPtr(clrFore(0))
OleTranslateColor clrSecond, 0, VarPtr(clrBack(0))

clrFore(0) = (clrFore(0) * lAlpha + clrBack(0) * (255 – lAlpha)) / 255
clrFore(1) = (clrFore(1) * lAlpha + clrBack(1) * (255 – lAlpha)) / 255
clrFore(2) = (clrFore(2) * lAlpha + clrBack(2) * (255 – lAlpha)) / 255

CopyMemory ShiftColor, clrFore(0), 4

End Function

‘Inicia GDI+
Private Sub InitGDI()
Dim GdipStartupInput As GDIPlusStartupInput
GdipStartupInput.GdiPlusVersion = 1&
Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub

‘Termina GDI+
Private Sub TerminateGDI()
Call GdiplusShutdown(GdipToken)
End Sub

[/code]

FillRectPlus

Gráficos No Responses »

Abr 022010

Esta función la misma pero utilizando GDI Plus con más opciones, es muy útil a hora de trabajar con gráficos ya que se gana mucha velocidad.

[code lang=»vb»]

Option Explicit
‘——————————————————
‘Autor: Leandro Ascierto
‘Web: www.leandroascierto.com.ar
‘Fecha 02/04/2010
‘——————————————————
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long, ByRef image As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipCreateTexture Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mWrapMode As WrapMode, ByRef mTexture As Long) As Long
Private Declare Function GdipFillRectangle Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Single, ByVal mY As Single, ByVal mWidth As Single, ByVal mHeight As Single) As Long
Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
Private Declare Function GdipScaleTextureTransform Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mSx As Single, ByVal mSy As Single, ByVal mOrder As Long) As Long
Private Declare Function GdipTranslateTextureTransform Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mDx As Single, ByVal mDy As Single, ByVal mOrder As Long) As Long

Private Enum WrapMode
WrapModeTile = &H0
WrapModeTileFlipX = &H1
WrapModeTileFlipy = &H2
WrapModeTileFlipXY = &H3
WrapModeClamp = &H4
End Enum

Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type

Private Const GdiPlusVersion As Long = 1&

Dim GdipToken As Long

Private Function FillRectPlus(ByVal hdc As Long, _
ByVal hImage As Long, _
ByVal x As Single, _
ByVal y As Single, _
ByVal Width As Single, _
ByVal Height As Single, _
Optional ByVal nScaleX As Single = 1, _
Optional ByVal nScaleY As Single = 1, _
Optional EnuWrapMode As WrapMode) As Boolean

Dim hGraphics As Long
Dim hBrush As Long

If GdipCreateFromHDC(Me.hdc, hGraphics) = 0 Then
If GdipCreateTexture(hImage, EnuWrapMode, hBrush) = 0 Then
Call GdipTranslateTextureTransform(hBrush, x, y, 0)
Call GdipScaleTextureTransform(hBrush, nScaleX, nScaleY, 0)
FillRectPlus = GdipFillRectangle(hGraphics, hBrush, x, y, Width, Height) = 0
Call GdipDeleteBrush(hBrush)
End If
Call GdipDeleteGraphics(hGraphics)
End If

End Function

Private Sub InitGDI()
Dim GdipStartupInput As GDIPlusStartupInput
GdipStartupInput.GdiPlusVersion = GdiPlusVersion
Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub

Private Sub TerminateGDI()
Call GdiplusShutdown(GdipToken)
End Sub

Private Sub Form_Load()
Dim hImage As Long
Me.AutoRedraw = True
InitGDI
If GdipLoadImageFromFile(StrPtr(App.Path & "\Text.png"), hImage) = 0 Then
FillRectPlus Me.hdc, hImage, 10, 10, 200, 200
Call GdipDisposeImage(hImage)
End If
TerminateGDI
End Sub
[/code]

Dibujar líneas con las Apis de Windows

Gráficos No Responses »

Oct 062009

Una función para tener siempre a mano, sobre todo para cuando trabajemos con hdc en memoria.

[code lang=»vb»]
Option Explicit
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpPoint As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function LineTo Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Public Sub DrawLine(ByVal hdc As Long, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long, _
Optional ByVal Color As Long = -1, _
Optional ByVal BorderWidth As Long = 1)

Dim hPen As Long
Dim TransColor As Long
Dim OldPen As Long

If Color <> -1 Then
Call OleTranslateColor(Color, 0&, TransColor)
hPen = CreatePen(0, BorderWidth, TransColor)
OldPen = SelectObject(hdc, hPen)
End If

If X1 >= 0 Then
MoveToEx hdc, X1, Y1, 0
End If

LineTo hdc, X2, Y2

If hPen <> 0 Then
SelectObject hdc, OldPen
DeleteObject hPen
End If

End Sub
[/code]

Render Stretch Plus

Gráficos No Responses »

Ago 012009

Igual que la función superior esta sirve para pintar una imágen de forma ampliada pero manteniendo su contorno original utilizando GDI PLUS, esto nos da como ventaja poder utilizar gráficos .PNG entre otros. Nótese que si ponemos el form con AutoRedraw = True la función trabaja más rápido.

[code lang=»vb»]
Option Explicit

‘ —————————————-
‘ Autor Leandro Ascierto
‘ Web www.leandroascierto.com.ar
‘ —————————————-
Private Declare Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal hGraphics As Long, ByVal hImage As Long, ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As Long = 0, Optional ByVal Callback As Long = 0, Optional ByVal CallbackData As Long = 0) As Long
Private Declare Function GdipSetInterpolationMode Lib "gdiplus" (ByVal graphics As Long, ByVal InterpolationMode As Long) As Long
Private Declare Function GdipSetPixelOffsetMode Lib "gdiplus" (ByVal graphics As Long, ByVal PixelOffsetMode As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long, ByRef image As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long

Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type

Private Const GdiPlusVersion As Long = 1&
Private Const QualityModeHigh As Long = 2&
Private Const InterpolationModeNearestNeighbor As Long = QualityModeHigh + 3
Private Const PixelOffsetModeHalf As Long = QualityModeHigh + 2

Dim GdipToken As Long
Dim m_hImage As Long

Private Sub RenderStretchPlus(ByVal DestHdc As Long, _
ByVal DestX As Long, _
ByVal DestY As Long, _
ByVal DestW As Long, _
ByVal DestH As Long, _
ByVal hImage As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal Width As Long, _
ByVal Height As Long, _
ByVal Size As Long)

Dim hGraphics As Long
Dim Sx2 As Long

Sx2 = Size * 2

If GdipCreateFromHDC(DestHdc, hGraphics) = 0 Then
Call GdipSetInterpolationMode(hGraphics, InterpolationModeNearestNeighbor)
Call GdipSetPixelOffsetMode(hGraphics, PixelOffsetModeHalf)

GdipDrawImageRectRectI hGraphics, hImage, DestX, DestY, Size, Size, x, y, Size, Size, &H2, 0&, 0&, 0& ‘TOP_LEFT
GdipDrawImageRectRectI hGraphics, hImage, DestX + Size, DestY, DestW – Sx2, Size, x + Size, y, Width – Sx2, Size, &H2, 0&, 0&, 0& ‘TOP_CENTER
GdipDrawImageRectRectI hGraphics, hImage, DestX + DestW – Size, DestY, Size, Size, x + Width – Size, y, Size, Size, &H2, 0&, 0&, 0& ‘TOP_RIGHT
GdipDrawImageRectRectI hGraphics, hImage, DestX, DestY + Size, Size, DestH – Sx2, x, y + Size, Size, Height – Sx2, &H2, 0&, 0&, 0& ‘MID_LEFT
GdipDrawImageRectRectI hGraphics, hImage, DestX + Size, DestY + Size, DestW – Sx2, DestH – Sx2, x + Size, y + Size, Width – Sx2, Height – Sx2, &H2, 0&, 0&, 0& ‘MID_CENTER
GdipDrawImageRectRectI hGraphics, hImage, DestX + DestW – Size, DestY + Size, Size, DestH – Sx2, x + Width – Size, y + Size, Size, Height – Sx2, &H2, 0&, 0&, 0& ‘MID_RIGHT
GdipDrawImageRectRectI hGraphics, hImage, DestX, DestY + DestH – Size, Size, Size, x, y + Height – Size, Size, Size, &H2, 0&, 0&, 0& ‘BOTTOM_LEFT
GdipDrawImageRectRectI hGraphics, hImage, DestX + Size, DestY + DestH – Size, DestW – Sx2, Size, x + Size, y + Height – Size, Width – Sx2, Size, &H2, 0&, 0&, 0& ‘BOTTOM_CENTER
GdipDrawImageRectRectI hGraphics, hImage, DestX + DestW – Size, DestY + DestH – Size, Size, Size, x + Width – Size, y + Height – Size, Size, Size, &H2, 0&, 0&, 0& ‘BOTTOM_RIGHT

Call GdipDeleteGraphics(hGraphics)
End If

End Sub

Private Sub RenderPlusFromFile(ByVal DestHdc As Long, _
ByVal DestX As Long, _
ByVal DestY As Long, _
ByVal DestW As Long, _
ByVal DestH As Long, _
ByVal FileName As String, _
ByVal x As Long, _
ByVal y As Long, _
ByVal Width As Long, _
ByVal Height As Long, _
ByVal Size As Long)
Dim hImg As Long

Call GdipLoadImageFromFile(StrPtr(FileName), hImg)
Call RenderStretchPlus(DestHdc, DestX, DestY, DestW, DestH, hImg, x, y, Width, Height, Size)
Call GdipDisposeImage(hImg)
End Sub

Private Sub InitGDI()
Dim GdipStartupInput As GDIPlusStartupInput
GdipStartupInput.GdiPlusVersion = GdiPlusVersion
Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub

Private Sub TerminateGDI()
Call GdiplusShutdown(GdipToken)
End Sub

Private Sub Command1_Click()
Cls
RenderPlusFromFile Me.hdc, 5, 5, 230, 230, App.Path & "\Image2.png", 0, 0, 158, 93, 26
End Sub

Private Sub Form_Load()
Call InitGDI
Call GdipLoadImageFromFile(StrPtr(App.Path & "\BotonesVista.png"), m_hImage)
Me.AutoRedraw = True ‘Utilizando GDIPlus + AutoRedraw = True, es mas rapido
End Sub

Private Sub Form_Terminate()
Call GdipDisposeImage(m_hImage)
Call TerminateGDI
End Sub

Private Sub Option1_Click(Index As Integer)
Cls
RenderStretchPlus Me.hdc, 10, 10, 120, 80, m_hImage, 0, 21 * Index, 11, 21, 3
End Sub
[/code]

Render Stretch

Gráficos No Responses »

Jul 232009

Esta es una función que sirve para pintar una imágen de forma ampliada pero manteniendo su contorno original, para que se entienda, cuando utilizamos PaintPicture o StretchBlt en una imágen, ésta se estira proporcionalmente y en un caso como éste (imágen) el borde del botón se deformaría, en esta función debe pasarse un parámetro en el cual debe indicarse un ancho/alto en común para los bordes.

[code lang=»vb»]
Option Explicit

‘ ————————————————-
‘ Autor: Leandro Ascierto
‘ Web: www.leandroascierto.com.ar
‘ ————————————————-

Private Declare Function StretchBlt Lib "gdi32.dll" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function BitBlt Lib "gdi32.dll" (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 CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GdiTransparentBlt Lib "gdi32.dll" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Function RenderStretchFromDC(ByVal DestDC As Long, _
ByVal DestX As Long, _
ByVal DestY As Long, _
ByVal DestW As Long, _
ByVal DestH As Long, _
ByVal SrcDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal Width As Long, _
ByVal Height As Long, _
ByVal Size As Long, _
Optional MaskColor As Long = -1)

Dim Sx2 As Long

Sx2 = Size * 2

If MaskColor <> -1 Then
Dim mDC As Long
Dim mX As Long
Dim mY As Long
Dim DC As Long
Dim hBmp As Long
Dim hOldBmp As Long

mDC = DestDC
DC = GetDC(0)
DestDC = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, DestW, DestH)
hOldBmp = SelectObject(DestDC, hBmp) ‘ save the original BMP for later reselection
mX = DestX: mY = DestY
DestX = 0: DestY = 0
End If

SetStretchBltMode DestDC, vbPaletteModeNone

BitBlt DestDC, DestX, DestY, Size, Size, SrcDC, x, y, vbSrcCopy ‘TOP_LEFT
StretchBlt DestDC, DestX + Size, DestY, DestW – Sx2, Size, SrcDC, x + Size, y, Width – Sx2, Size, vbSrcCopy ‘TOP_CENTER
BitBlt DestDC, DestX + DestW – Size, DestY, Size, Size, SrcDC, x + Width – Size, y, vbSrcCopy ‘TOP_RIGHT
StretchBlt DestDC, DestX, DestY + Size, Size, DestH – Sx2, SrcDC, x, y + Size, Size, Height – Sx2, vbSrcCopy ‘MID_LEFT
StretchBlt DestDC, DestX + Size, DestY + Size, DestW – Sx2, DestH – Sx2, SrcDC, x + Size, y + Size, Width – Sx2, Height – Sx2, vbSrcCopy ‘MID_CENTER
StretchBlt DestDC, DestX + DestW – Size, DestY + Size, Size, DestH – Sx2, SrcDC, x + Width – Size, y + Size, Size, Height – Sx2, vbSrcCopy ‘MID_RIGHT
BitBlt DestDC, DestX, DestY + DestH – Size, Size, Size, SrcDC, x, y + Height – Size, vbSrcCopy ‘BOTTOM_LEFT
StretchBlt DestDC, DestX + Size, DestY + DestH – Size, DestW – Sx2, Size, SrcDC, x + Size, y + Height – Size, Width – Sx2, Size, vbSrcCopy ‘BOTTOM_CENTER
BitBlt DestDC, DestX + DestW – Size, DestY + DestH – Size, Size, Size, SrcDC, x + Width – Size, y + Height – Size, vbSrcCopy ‘BOTTOM_RIGHT

If MaskColor <> -1 Then
GdiTransparentBlt mDC, mX, mY, DestW, DestH, DestDC, 0, 0, DestW, DestH, MaskColor
SelectObject DestDC, hOldBmp
DeleteObject hBmp
DeleteDC DC
DeleteDC DestDC
End If

End Function

Private Function RenderStretchFromPicture(ByVal DestDC As Long, _
ByVal DestX As Long, _
ByVal DestY As Long, _
ByVal DestW As Long, _
ByVal DestH As Long, _
ByVal SrcPicture As StdPicture, _
ByVal x As Long, _
ByVal y As Long, _
ByVal Width As Long, _
ByVal Height As Long, _
ByVal Size As Long, _
Optional MaskColor As Long = -1)

Dim DC As Long
Dim hOldBmp As Long

DC = CreateCompatibleDC(0)
hOldBmp = SelectObject(DC, SrcPicture.Handle)

RenderStretchFromDC DestDC, DestX, DestY, DestW, DestH, DC, x, y, Width, Height, Size, MaskColor

hOldBmp = SelectObject(DC, hOldBmp)
DeleteDC DC

End Function
[/code]

DrawShadowText

Gráficos No Responses »

May 102009

Esta es una Api que sirve para dibujar texto con una sombra difuminada al estilo Windows Vista, en el siguiente ejemplo he creado una pequeña función a modo de simplificarla un poco, pero esto depende del uso que se le quiera dar.
Lo malo de esta Api es que requiere que esté inicializada comctl32.dll, es decir, que tendremos que llamar a InitCommonControls y tener el archivo .manifest para que funcione, por lo tanto desde el IDE si no se tiene aplicado los temas de Windows en el VB6.EXE no se mostrará el dibujo del texto y además nos dará un error al llamar a esta Api, el cual lo podremos controlar con On Error, pero bien al compilarlo y teniendo el .manifest funcionará perfectamente.

Draw Shadow Text

[code lang=»vb»]

Option Explicit

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function DrawText Lib "user32.dll" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, ByRef lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawShadowText Lib "comctl32.dll" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal dwFlags As Long, ByVal crText As Long, ByVal crShadow As Long, ByVal ixOffset As Long, ByVal iyOffset As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Const DT_CALCRECT As Long = &H400

Public Function DrawTextShadow (DestDC As Long, Text As String, ByVal x As Long, ByVal y As Long, TextColor As OLE_COLOR, ShadowColor As OLE_COLOR, Optional OffsetX As Long = 1, Optional OffsetY As Long = 1) As Boolean

On Error Resume Next ‘Si no incluye el archivo .manifest el api DrawShadowText provoca un error

Dim Color1 As Long
Dim Color2 As Long
Dim Rec As RECT

TranslateColor TextColor, 0, Color1
TranslateColor ShadowColor, 0, Color2

DrawText DestDC, Text, Len(Text), Rec, DT_CALCRECT
OffsetRect Rec, x, y

If Color1 = 0 Then Color1 = 1
‘ El quinto parámetro es la alineación, en este caso 0 = izquierda, 1 centrado, 2 derecha
DrawTextShadow = DrawShadowText(DestDC, StrPtr(Text), Len(Text), Rec, 0, Color1, Color2, OffsetX, OffsetY)
‘ Esta función podría ser modificada en caso de el api DrawShadowText diera error, podría ser suplementada con DrawText

End Function

Private Sub Form_Initialize()
InitCommonControls
End Sub

Private Sub Form_Load()

Me.AutoRedraw = True
Me.Font.Size = 8

If DrawTextShadow(Me.hdc, "Hola Mundo", 10, 10, vbBlack, vbRed) = False Then
MsgBox "Para probar este ejemplo debe compilar este proyecto y agregar un archivo Proyecto1.exe.manifest", vbInformation
End If

Me.Font.Size = 12
DrawTextShadow Me.hdc, "Hola Mundo", 10, 30, vbBlue, vbRed
Me.Font.Size = 32
Me.Font.Name = "Times New Roman"
DrawTextShadow Me.hdc, "Hola Mundo", 10, 50, vbGreen, vbMagenta
DrawTextShadow Me.hdc, "Hola Mundo", 10, 90, Me.BackColor, vbBlue
Me.FontBold = True
DrawTextShadow Me.hdc, "Hola" & vbCrLf & "Mundo", 10, 130, vbWhite, vbBlack, 3, 3
End Sub

Private Sub Timer1_Timer()
Picture1.Cls
DrawTextShadow Picture1.hdc, Now, 5, 0, &H333333, &H80000005
End Sub

[/code]

DrawGrìp

Gráficos No Responses »

May 012009

Esta es una función simple para dibujar puntos sobre un Formulario, Picture Box o hdc, la función es rápida.

Draw Grip

[code lang=»vb»]
Option Explicit

‘=========GDI32 Api========
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SetRect Lib "user32.dll" (ByRef lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetDCBrushColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetBkColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SetPixelV Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GdiTransparentBlt Lib "gdi32.dll" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean

‘============User32 Api===========
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long

‘============Estructura Rect========
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Function ShiftColor(ByVal clr As Long, ByVal d As Long) As Long
Dim R As Long, B As Long, G As Long
R = (clr And &HFF) + d
G = ((clr \ &H100) Mod &H100) + d
B = ((clr \ &H10000) Mod &H100) + d

If (d > 0) Then
If (R > &HFF) Then R = &HFF
If (G > &HFF) Then G = &HFF
If (B > &HFF) Then B = &HFF
ElseIf (d < 0) Then
If (R < 0) Then R = 0
If (G < 0) Then G = 0
If (B < 0) Then B = 0
End If
ShiftColor = R + &H100& * G + &H10000 * B
End Function

Public Sub DrawGrip(DestDC As Long, DestX As Long, DestY As Long, DestWidth As Long, DestHeight As Long)
Dim DC As Long
Dim hDCMemory As Long
Dim hBmp As Long
Dim hOldBmp As Long
Dim hBrush As Long
Dim Rec As RECT
Dim lOriginalColor As Long
Dim clrHighLight As Long
Dim clrShadow As Long

lOriginalColor = GetBkColor(DestDC)
clrHighLight = ShiftColor(lOriginalColor, &H40)
clrShadow = ShiftColor(lOriginalColor, -&H40)

DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, 6, 6)
hOldBmp = SelectObject(hDCMemory, hBmp)

hBrush = CreateSolidBrush(lOriginalColor)
SetRect Rec, 0, 0, 6, 6
FillRect hDCMemory, Rec, hBrush
DeleteObject hBrush

SetPixelV hDCMemory, 2, 1, clrShadow
SetPixelV hDCMemory, 1, 2, clrShadow
SetPixelV hDCMemory, 2, 2, clrShadow

SetPixelV hDCMemory, 0, 0, clrHighLight
SetPixelV hDCMemory, 1, 0, clrHighLight
SetPixelV hDCMemory, 0, 1, clrHighLight
SetPixelV hDCMemory, 1, 1, clrHighLight

SetPixelV hDCMemory, 5, 4, clrShadow
SetPixelV hDCMemory, 4, 5, clrShadow
SetPixelV hDCMemory, 5, 5, clrShadow

SetPixelV hDCMemory, 3, 3, clrHighLight
SetPixelV hDCMemory, 4, 3, clrHighLight
SetPixelV hDCMemory, 3, 4, clrHighLight
SetPixelV hDCMemory, 4, 4, clrHighLight

hBrush = CreatePatternBrush(hBmp)
SelectObject hDCMemory, hOldBmp
DeleteObject hBmp
hBmp = CreateCompatibleBitmap(DC, DestWidth, DestHeight)
hOldBmp = SelectObject(hDCMemory, hBmp)
SetRect Rec, 0, 0, DestWidth, DestHeight
FillRect hDCMemory, Rec, hBrush

GdiTransparentBlt DestDC, DestX, DestY, DestWidth, DestHeight, hDCMemory, 0, 0, DestWidth, DestHeight, lOriginalColor

DeleteObject hBrush
SelectObject hDCMemory, hOldBmp
DeleteObject hBmp
DeleteDC DC
DeleteDC hDCMemory
End Sub

Private Sub Form_Paint()
DrawGrip Me.hdc, 0, 50, Me.ScaleWidth / Screen.TwipsPerPixelX, 9
DrawGrip Me.hdc, 100, 59, 16, Me.ScaleHeight / Screen.TwipsPerPixelY – 59
End Sub
[/code]

DrawAlphaSelection

Gráficos 1 Response »

May 012009

Esta es una función para dibujar una selección al estilo Windows XP.

Draw Alpha Selection

[code lang=»vb»]

Option Explicit

‘=========Gdi32 Api========
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GdiAlphaBlend Lib "gdi32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
‘=========user32 Api========
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long

‘=========Oleaut32 Api========
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long

‘=========Kernel32 Api========
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Type UcsRgbQuad
R As Byte
G As Byte
B As Byte
a As Byte
End Type

Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type

Private Sub DrawAlphaSelection(hdc As Long, ByVal X As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As OLE_COLOR)

Dim BF As BLENDFUNCTION
Dim hDCMemory As Long
Dim hBmp As Long
Dim hOldBmp As Long
Dim DC As Long
Dim lColor As Long
Dim hPen As Long
Dim hBrush As Long
Dim lBF As Long

BF.SourceConstantAlpha = 128

DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, Width, Height)
hOldBmp = SelectObject(hDCMemory, hBmp)

hPen = CreatePen(0, 1, Color)
hBrush = CreateSolidBrush(pvAlphaBlend(Color, vbWhite, 120))
DeleteObject SelectObject(hDCMemory, hBrush)
DeleteObject SelectObject(hDCMemory, hPen)
Rectangle hDCMemory, 0, 0, Width, Height

CopyMemory VarPtr(lBF), VarPtr(BF), 4
GdiAlphaBlend hdc, X, y, Width, Height, hDCMemory, 0, 0, Width, Height, lBF

SelectObject hDCMemory, hOldBmp
DeleteObject hBmp
ReleaseDC 0&, DC
DeleteDC hDCMemory
DeleteObject hPen
DeleteObject hBrush

End Sub

Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long

Dim clrFore As UcsRgbQuad
Dim clrBack As UcsRgbQuad

OleTranslateColor clrFirst, 0, VarPtr(clrFore)
OleTranslateColor clrSecond, 0, VarPtr(clrBack)
With clrFore
.R = (.R * lAlpha + clrBack.R * (255 – lAlpha)) / 255
.G = (.G * lAlpha + clrBack.G * (255 – lAlpha)) / 255
.B = (.B * lAlpha + clrBack.B * (255 – lAlpha)) / 255
End With
CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4

End Function

Private Sub Form_Paint()
Cls
DrawAlphaSelection Me.hdc, 10, 50, 100, 200, vbRed
DrawAlphaSelection Me.hdc, 50, 30, 200, 100, vbBlue
DrawAlphaSelection Me.hdc, 200, 80, 100, 100, vbGreen
DrawAlphaSelection Me.hdc, 80, 200, 200, 30, vbYellow
DrawAlphaSelection Me.hdc, 130, 70, 50, 200, vbMagenta
End Sub
[/code]

Texto Espejado

Gráficos No Responses »

Abr 192009

Esta es una función que se encarga de dibujar un texto con un efecto espejado al estilo Windows Vista.

Texto Espejado

[code lang=»vb»]
‘—————————–‘
‘Autor: Leandro Ascierto
‘Fecha: 27/11/2008
‘Tercera Revision
‘—————————–‘

Option Explicit
Private Declare Function GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" (ByVal hdc As Long, ByRef lpMetrics As TEXTMETRIC) As Long
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt Lib "gdi32.dll" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function DrawText Lib "user32.dll" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, ByRef lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function GetBkMode Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetCurrentObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
Private Declare Function GetTextColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetBkColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SetTextColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)

Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type

Private Const DT_CALCRECT As Long = &H400
Private Const DT_BOTTOM As Long = &H8
Private Const DT_SINGLELINE As Long = &H20
Private Const OBJ_FONT As Long = 6
Private Const AC_SRC_OVER As Long = &H0

Public Enum tShadowDirection
sdCenter = 0
sdLeft = 1
sdRight = 2
sdInside = 3
sdOutside = 4
End Enum

Public Enum tPercent
Percent100 = 0
Percent75 = 1
Percent50 = 2
Percent25 = 3
End Enum

Public Function DrawTextReflecion(DestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
Text As String, _
Optional ByVal IgnoreTMDescent As Boolean, _
Optional ByVal WaveIntesity As Long, _
Optional ByVal ShadowDirection As tShadowDirection, _
Optional ByVal Color As OLE_COLOR = -1, _
Optional ByVal ShadowPecent As tPercent = Percent75, _
Optional ByVal BackLight As Boolean = True)

Dim ShadowLeft As Long, ShadowRight As Long
Dim Left As Long, Top As Long, Width As Long, Height As Long
Dim DC As Long, MemDC As Long, hBmp As Long, OldhBmp As Long, OldhFont As Long
Dim BF As BLENDFUNCTION, lBF As Long
Dim TM As TEXTMETRIC
Dim Rec As RECT
Dim i As Integer

Dim Percent As Single

‘Calculamos el tamaño del texto
DrawText DestDC, Text, Len(Text), Rec, DT_CALCRECT

Width = Rec.Right
Height = Rec.Bottom

‘Creamos un Bitmap
DC = GetDC(0)
MemDC = CreateCompatibleDC(DC)
hBmp = CreateCompatibleBitmap(DC, Width, Height)
OldhBmp = SelectObject(MemDC, hBmp)
ReleaseDC 0&, DC

‘Copiamos la fuente de destino
OldhFont = SelectObject(MemDC, GetCurrentObject(DestDC, OBJ_FONT))

‘Copiamos el BackMode de destino
SetBkMode MemDC, GetBkMode(DestDC)

‘Copiamos el color de texto de destino
SetTextColor MemDC, IIf(Color <> -1, Color, GetTextColor(DestDC))

‘Tomamos una captura del destino
StretchBlt MemDC, 0, 0, Width, Height, DestDC, x, y + Height * 2, Width, -Height, vbSrcCopy

OffsetRect Rec, 0, 0
‘dibujamos el texto
DrawText MemDC, Text, Len(Text), Rec, DT_BOTTOM Or DT_SINGLELINE

‘obtenemos informacion de la metrica de la fuente.
GetTextMetrics MemDC, TM

Select Case ShadowPecent
Case 0: Percent = TM.tmAscent / 1
Case 1: Percent = TM.tmAscent / 1.25
Case 2: Percent = TM.tmAscent / 1.65
Case 3: Percent = TM.tmAscent / 2
Case Else: Percent = TM.tmAscent
End Select

‘pintamos el hdc utilizando AlphaBlend para provocar el espejado.
For i = TM.tmDescent To Percent
With BF
.BlendOp = AC_SRC_OVER
.SourceConstantAlpha = Abs(200 – ((20 * i) / Percent) * 10)
End With
RtlMoveMemory lBF, BF, 4

Select Case ShadowDirection
Case 1
ShadowLeft = -i + TM.tmDescent
Case 2
ShadowLeft = i – TM.tmDescent
Case 3
ShadowLeft = -i + TM.tmDescent
ShadowRight = (i – TM.tmDescent) * 2
Case 4
ShadowLeft = i – TM.tmDescent
ShadowRight = -(i – TM.tmDescent) * 2
End Select

Top = y + Height – 1
Left = x – (Rnd(i) * WaveIntesity) + ShadowLeft
AlphaBlend DestDC, Left, Top + IIf(BackLight, i, -i), Width + ShadowRight, 1, MemDC, 0, Height – i, Width, 1, lBF
Next

OffsetRect Rec, x, y + IIf(IgnoreTMDescent And BackLight, TM.tmDescent * 2, 0)

‘Bibujamos el texto original
DrawText DestDC, Text, Len(Text), Rec, DT_BOTTOM Or DT_SINGLELINE

‘limpiamos la memoria
SelectObject MemDC, OldhFont
SelectObject MemDC, OldhBmp
DeleteDC MemDC
DeleteObject hBmp
End Function
[/code]

FillRectEx

Gráficos 1 Response »

Abr 192009

Función para rellenar un rectángulo en un hdc con parte o el total de otro hdc, la función es muy rápida en dibujar.

Fill Rect Ex

[code lang=»vb»]

Option Explicit
‘ ——————————–
‘ Autor Leandro Ascierto
‘ ——————————–
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 SetBrushOrgEx Lib "gdi32.dll" (ByVal hdc As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, ByRef lppt As POINTAPI) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Type POINTAPI
x As Long
y As Long
End Type

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

‘ Función que rellena un hdc con el contenido de otro en forma repetitiva
Private Sub FillRectEx(DestDC As Long, DestX As Long, DestY As Long, DestWidth As Long, DestHeight As Long, SrcDC As Long, SrcX As Long, SrcY As Long, SrcWidth As Long, SrcHeight As Long)

Dim DC As Long
Dim hDCMemory As Long
Dim hBmp As Long
Dim OldhBmp As Long
Dim hBrush As Long
Dim Rec As RECT
Dim PT As POINTAPI

DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, SrcWidth, SrcHeight)
ReleaseDC 0&, DC
OldhBmp = SelectObject(hDCMemory, hBmp)
BitBlt hDCMemory, 0, 0, SrcWidth, SrcHeight, SrcDC, SrcX, SrcY, vbSrcCopy
hBrush = CreatePatternBrush(hBmp)
SetRect Rec, DestX, DestY, DestWidth + DestX, DestHeight + DestY

SetBrushOrgEx hdc, DestX, DestY, PT
FillRect DestDC, Rec, hBrush
SetBrushOrgEx hdc, PT.x, PT.y, PT

DeleteObject hBrush
DeleteObject SelectObject(hDCMemory, OldhBmp)
DeleteDC hDCMemory
End Sub

Private Sub Form_Load()
With Picture1
.Visible = False
.AutoSize = True
.ScaleMode = vbPixels
.AutoRedraw = True
.Picture = Me.Icon
End With
End Sub

Private Sub Form_Paint()
FillRectEx Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight
End Sub
[/code]

DrawSelectionEx

Gráficos No Responses »

Abr 192009

Este es una función para dibujar una selección al estilo Windows Vista o MSN, útil para hacer controles de usuarios o según la necesidad de cada uno. creo que si bien es hay unas cuantas Apis, la función es muy rápida en dibujar.

Draw Selection Ex

[code lang=»vb»]

Option Explicit
‘ —————————————————
‘ Autor: Leandro Ascierto
‘ —————————————————-

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function SetPixelV Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function RoundRect Lib "gdi32.dll" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor 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 OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Type UcsRgbQuad
R As Byte
G As Byte
B As Byte
a As Byte
End Type

Private Sub DrawSelectionEx(DestDC As Long, DestX As Long, DestY As Long, DestWidth As Long, DestHeight As Long, oColorStar As Long, oColorEnd As Long)
Dim DC As Long, hDCMemory As Long, hBmp As Long
Dim hPen1 As Long, hPen2 As Long, hBrush As Long
Dim OldhBmp As Long, OldhPen As Long, OldhBrush As Long
Dim DivValue As Double
Dim i As Long

‘ Creamos una Pluma oscura para el borde
hPen1 = CreatePen(0, 1, pvAlphaBlend(vbBlack, oColorEnd, 10))

‘ Creamos un Pluma para un pequeño borde interior, bien claro
hPen2 = CreatePen(0, 1, pvAlphaBlend(oColorStar, vbWhite, 10))

‘ Creamos un HDC temporal
DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, 1, DestHeight)
OldhBmp = SelectObject(hDCMemory, hBmp)

‘ Creamos un bucle haciendo un degradado
For i = 1 To DestHeight
DivValue = ((i * 255) / DestHeight)
SetPixelV hDCMemory, 0, i, pvAlphaBlend(oColorEnd, oColorStar, DivValue)
Next

‘ Creamos una brocha con el bmp
hBrush = CreatePatternBrush(hBmp)

‘ Creamos un buffer temporal
DeleteObject hBmp
hBmp = CreateCompatibleBitmap(DC, DestWidth, DestHeight)
Call SelectObject(hDCMemory, hBmp)

‘ Pintamos el destino en el buffer
BitBlt hDCMemory, 0, 0, DestWidth, DestHeight, DestDC, DestX, DestY, vbSrcCopy

‘ Le asignamos la pluma al hdc de destino
OldhPen = SelectObject(hDCMemory, hPen1)

‘ Pintamos un borde oscuro alrededor sin relleno
RoundRect hDCMemory, 0, 0, DestWidth, DestHeight, 9, 9

‘ Asignamos la segunda pluma más clara
Call SelectObject(hDCMemory, hPen2)

‘ Creamos y asignamos una brocha con el bmp de nuestro degradado
OldhBrush = SelectObject(hDCMemory, hBrush)

‘ Pintamos un rectángulo redondeado con la pluma y la brocha
RoundRect hDCMemory, 1, 1, DestWidth – 1, DestHeight – 1, 8, 8

‘ Pintamos el buffer en el destino
BitBlt DestDC, DestX, DestY, DestWidth, DestHeight, hDCMemory, 0, 0, vbSrcCopy

‘ Descargamos todo
SelectObject hDCMemory, OldhPen
SelectObject hDCMemory, OldhBrush
SelectObject hDCMemory, OldhBmp
DeleteObject hPen1
DeleteObject hPen2
DeleteObject hBrush
DeleteObject hBmp
ReleaseDC 0&, DC
DeleteDC hDCMemory

End Sub

‘ Función para trasladar un color a otro en porcentaje lAlpha(0 A 255)
Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long

Dim clrFore As UcsRgbQuad
Dim clrBack As UcsRgbQuad

CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4

End Function

Private Sub Form_Load()
Me.ScaleMode = vbPixels
Me.FontName = "Calibri"
Me.FontSize = 12
Me.BackColor = vbWhite
Me.Width = 8500
Me.Height = 8700
HScroll1.Max = 255
HScroll1.Value = 70
HScroll1.Move 320, 210, 230, 30
End Sub

‘ Ejemplo de uso
Private Sub Form_Paint()

Dim i As Integer

‘ Colores empleados en Windows Vista, y MSN
DrawSelectionEx Me.hdc, 320, 10, 100, 100, RGB(249, 253, 255), RGB(234, 247, 255)
DrawSelectionEx Me.hdc, 440, 10, 100, 100, RGB(251, 251, 251), RGB(231, 231, 231)

‘ Con quince colores diferentes
For i = 0 To 15
DrawSelectionEx Me.hdc, 10, 10 + (i * 35), 300, 30, Me.BackColor, pvAlphaBlend(QBColor(i), Me.BackColor, HScroll1.Value)
Next

‘ Utilizando el color resalte del sistema
DrawSelectionEx Me.hdc, 320, 120, 220, 70, Me.BackColor, pvAlphaBlend(vbHighlight, Me.BackColor, 50)

Me.CurrentX = 330
Me.CurrentY = 145
Me.Print "Color de selección del Sistema"

End Sub

Private Sub HScroll1_Change()
Form_Paint
End Sub
[/code]