Ejemplos usando el Api de windows para Visual basic

95 - Ejemplo para aplicar textura a un Texto

Volver al Listado Api - Anterior - Siguiente

Contenido

Ejemplo 1
Ejemplo 2
Ejemplo 3
Relacionados

Ejemplo 1

Ejemplo publicado en el ApiGuide, que utiliza las siguientes funciones Api para aplicar una textura a un texto, que se imprime o dibuja en un control Picture:

BeginPath
EndPath
TextOut
SelectClipPath
BitBlt

Vista del formulario para aplicar la textura

Vista del ejemplo que tuliza el Api BitBit y TextOut entre otros para añadir una textura a un texto

Nota: Asi como está planteado el ejemplo, la textura para aplicar al texto, es decir la imagen cargada en el Picture2, debe tener el ancho y alto del texto, si el alto o ancho es menor al ancho o alto del texto, solo aplicará la textura de dicha área

Para probar colocar los siguientes controles como muestra el gráfico:

Controles:

Un Picture1 (Donde se visualiza el texto)
Un Picture2 ( Donde se carga el gráfico).
Un Commondialog
Un control de texto ( Text1 )
Dos Command Buttons ( Command1 y Command2)

Código en un formulario.

Option Explicit 'Declaraciones APi Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Sub TextOut _ Lib "gdi32" _ Alias "TextOutA" ( _ ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal lpString As String, _ ByVal nCount 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 SelectClipPath _ Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal iMode As Long) As Long 'Constantes Private Const SRCCOPY As Long = &HCC0020 Private Const RGN_COPY As Long = &H5& Private Sub Command1_Click() With CommonDialog1 .Filter = "Archivos BMP|*.bmp|Archivos JPG|*.Jpg" .ShowOpen ' abrir el diálogo para seleccionar la imagen JPG o BMP para la textura If .FileName = "" Then Exit Sub Picture2 = LoadPicture(.FileName) End With End Sub Private Sub Command2_Click() ' limpiar el dibujo previo Picture1.Cls With Picture1 Call BeginPath(.hdc) ' Indicar Dispositivo de contexto Destino, las coordenadas x e y el texto TextOut .hdc, 5, 5, Text1.Text, Len(Text1) Call EndPath(.hdc) ' La función SelectClipPath selecciona el camino actual como región de recorte para el contexto de dispositivo, combinando la nueva región con cualquiera existente usando el modo especificado. ' http://winapi.conclase.net/curso/index.php?fun=SelectClipPath Call SelectClipPath(.hdc, RGN_COPY) 'Dibujar en el Picture1 el texto con la textura cargada en el Pic2 Call BitBlt(.hdc, 5, 5, Picture2.ScaleWidth, Picture2.ScaleHeight, Picture2.hdc, 0, 0, SRCCOPY) End With End Sub Private Sub Form_Load() ' Establecer el modo de persistencia gráfica para que al repintar la ventana del formulario o el picture se mantenga el dibujo Picture1.AutoRedraw = True Picture1.ScaleMode = vbPixels Picture2.ScaleMode = vbPixels Command1.Caption = " Cargar textura >> " Command2.Caption = "Crear textura" ' Propiedades de fuente para el picturebox With Picture1 .FontName = "Verdana" .FontBold = True .FontSize = 60 ' otras End With End Sub

Ejemplo 2

Este es el mismo código que el anterior, pero en ves de utilizar el Picture2 para poder cargar la textura y luego dibujar el resultado final en el otro picturebox, se crea un dispositivo de contexto (HDC) con la función createCompatibleDC. De esta forma no dependemos de un control temporal.

En este caso, la textura se dibujará en el formulario

Nota: indicar la ruta para el gráfico de textura en el evento FormLoad, y establecer las propiedades del formulario : Fuente, tamaño etc ..

Pegar el código fuente

Option Explicit ' Declaraciones de funciones Apis ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleDC 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 BeginPath Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Sub TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) Private Declare Function SelectClipPath Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long 'Constantes Private Const SRCCOPY As Long = &HCC0020 Private Const RGN_COPY As Long = &H5& ' Función '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub mCreateTexture( _ Obj As Object, _ stdPicTexture As StdPicture, _ sText As String, _ lPosx As Long, _ lPosy As Long) ' Dispositivo de contexto para establecer la imagen Dim hDCMemory As Long Dim lWidth As Long Dim lHeight As Long ' Obtener las dimensiones de la textura : Ancho y alto en pixeles lWidth = ScaleX(stdPicTexture.Width, vbHimetric, vbPixels) lHeight = ScaleY(stdPicTexture.Height, vbHimetric, vbPixels) 'Comprobar el ancho y alto de la imagen de textura ( el valor es pixeles ) With Obj If .TextWidth(sText) > lWidth Then MsgBox "El ancho de la imagen de textura es menor al ancho del texto. La imagen debe ser igual o mas grande", vbExclamation Exit Sub End If If .TextHeight(sText) > lHeight Then MsgBox "El alto de la imagen de textura es menor al alto del texto. La imagen debe ser igual o mas grande", vbExclamation Exit Sub End If End With ' crear un DC temporal hDCMemory = CreateCompatibleDC(0) ' Seleccionar la imagen de textura en el DC anterior Call SelectObject(hDCMemory, stdPicTexture.Handle) With Obj Call BeginPath(.hdc) ' Dibujar texto en el objeto, en este caso en la ventana del formulario Call TextOut(.hdc, lPosx, lPosy, sText, Len(sText)) Call EndPath(.hdc) ' combinar los DC ( http://winapi.conclase.net/curso/index.php?fun=SelectClipPath) Call SelectClipPath(.hdc, RGN_COPY) ' Copiar el hDCMemory --> en el otro DC, en este caso en el del formulario Call BitBlt(.hdc, lPosx, lPosy, lWidth, lHeight, hDCMemory, 0, 0, &HCC0020) Call DeleteDC(hDCMemory) ' liberar recursos .Refresh ' refrescar el objeto End With End Sub Private Sub Form_Load() ' Establecer propiedades varias del objeto donde dibujar la textura ( En este caso en En el Form ) ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With Me ' Establecer el modo de persistencia para mantener la imagen .AutoRedraw = True ' fuente .FontName = "Arial Black" .FontSize = 48 ' escala .ScaleMode = vbPixels Me.BackColor = vbBlack End With ' asignar el path Dim sPath As String sPath = "C:\WINDOWS\Web\Wallpaper\felicidad.bmp" ' verificar que la ruta de la imagen existe If Len(Dir(sPath)) = 0 Then MsgBox "La ruta de la imagen no es válida.", vbCritical End End If 'Cargar una imagen de textura en un objeto de imagen StdPicture Dim sPicTexture As StdPicture ' Cargarlo con la función LoadPicture Set sPicTexture = LoadPicture(sPath) ' Crear la textura ( Pasar comoparámetro el objeto ( el form , picbox etc ..), el texto, y la posición x e y) Call mCreateTexture(Me, sPicTexture, "Visual basic ..", 10, 10) End Sub

Texto espejado

Este es un muy buen ejemplo programado por Leandro Ascierto que muestra como dibujar un texto espejado utilizando varias funciones de la librería gdi32.dll, como DrawText, AlphaBlend y StretchBlt

Ver ejemplo

Enlaces relacionados

Buscar en Recursos vb