Rutina para crear una marquesina parecida a la utilizada en las páginas
web para funcionar en un control de un formulario. (en el caso de ejemplo
utilizo una etiqueta. Imagino que se podrá hacer funcionar en cuadro de
texto también).
En un formulario creamos una etiqueta llamada "eti" con la longitud que
creamos conveniente (hay que ponerle un texto - aunque sea una sola letra
pues sino Access no la aceptará). En la propiedad "Intervalo de cronometro"
del formulario ponemos, por ejemplo 100.
Y en el formulario escribiríamos este código (eventos Load y Timer)
'****************** CODIGO FORMULARIO *********************
Dim blancos As Integer
Private Sub Form_Load()
'calculamos cuantos twips tiene un blanco
blancos = StringToTwips(Me.eti, " ")
'calculamos a cuantos blancos corresponde la longitud
'total del control que contendrá la marquesina
blancos = Me.eti.Width / blancos
End Sub
Private Sub Form_Timer()
Dim cadena As String
' se asigna una cadena de texto para que aparezca
' en la marquesina
cadena = "Texto que se supone se tiene que deslizar "
cadena = cadena & "sobre el control en cuestión,"
cadena = cadena & " u otra burrada semejante."
' la cadena será igual a la cantidad proporcional
' de blancos, que es la longitud del control,
' más la cadena de texto. De esta manera se cons-
' truye el efecto de que la cadena de texto
' "aparezca" por la derecha del control
cadena = String(blancos, " ") & cadena
eti.Caption = Marquesina(cadena)
End Sub
'************** FIN CODIGO FORMULARIO **********************
El siguiente código ha de ser copiado en un módulo estandar.
Estas funciones del API calculan la longitud de un caracter
en el tipo de fuente que esté asignada al control
que contiene la marquesina.
'****************** CODIGO MODULO ************************
Option Compare Database
Option Explicit
'Autores: Stephen Lebans
' Terry Kreft
'Fecha: 14 Dic 1999
'Copyright: Lebans Holdings (1999) Ltd.
' Terry Kreft
'Uso(original):Alinear al centro o derecha datos
' en un combobox o listbox.
'Uso(actual): Aquí los utilizo para calcular la
' longitud en Twips de la fuente utilizada
' en el control de la marquesina
'Bugs: Házmelo saber si encuentras alguno.
'Contactar: Stephen@lebans.com
Private Type Size
cx As Long
cy As Long
End Type
Private Const LF_FACESIZE = 32
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Declare Function apiCreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lplogfont As LOGFONT) As Long
Private Declare Function apiSelectObject Lib "gdi32" _
Alias "SelectObject" _
(ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function apiGetDC Lib "user32" _
Alias "GetDC" _
(ByVal hWnd As Long) As Long
Private Declare Function apiReleaseDC Lib "user32" _
Alias "ReleaseDC" _
(ByVal hWnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function apiDeleteObject Lib "gdi32" _
Alias "DeleteObject" _
(ByVal hObject As Long) As Long
Private Declare Function apiGetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hDC As Long, _
ByVal lpsz As String, _
ByVal cbString As Long, _
lpSize As Size) As Long
' Crear un contexto de información
Declare Function apiCreateIC Lib "gdi32" _
Alias "CreateICA" _
(ByVal lpDriverName As String, _
ByVal lpDeviceName As String, _
ByVal lpOutput As String, _
lpInitData As Any) As Long
' Cerrar contexto de dispositivo existente
' (o un contexto de información)
Declare Function apiDeleteDC Lib "gdi32" _
Alias "DeleteDC" _
(ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, _
ByVal nIndex As Long) As Long
' Constantes
Private Const LOGPIXELSX = 88
Function StringToTwips(ctl As Control, strText As String) As Long
Dim myfont As LOGFONT
Dim stfSize As Size
Dim lngLength As Long
Dim lngRet As Long
Dim hDC As Long
Dim lngscreenXdpi As Long
Dim fontsize As Long
Dim hfont As Long, prevhfont As Long
' Obtener el contexto de dispositivo del escritorio
hDC = apiGetDC(0&)
' Obtener los Twips por Pixel actuales
lngscreenXdpi = GetTwipsPerPixel()
' Construir nuestra estructura LogFont.
' Se requiere para compararla con la fuente
' seleccionada en el control que pasamos
' como parámetro a la función.
' Copiamos las características de la fuente
' del control en la estructura LogFont
With myfont
.lfFaceName = ctl.FontName & Chr$(0) '+ un caracter nulo
fontsize = ctl.fontsize
.lfWeight = ctl.FontWeight
.lfItalic = ctl.FontItalic
.lfUnderline = ctl.FontUnderline
' Este valor debe ser negativo
.lfHeight = (fontsize / 72) * -lngscreenXdpi
End With
' Creamos nuestra propia fuente
hfont = apiCreateFontIndirect(myfont)
' Ponemos nuestra fuente en el contexto de dispositivo
prevhfont = apiSelectObject(hDC, hfont)
' Tomamos el ancho y el alto
lngLength = Len(strText)
lngRet = apiGetTextExtentPoint32(hDC, strText, lngLength, stfSize)
' Ponemos la fuente original dentro del contexto de dispositivo
hfont = apiSelectObject(hDC, prevhfont)
' Borramos nuestra fuente
lngRet = apiDeleteObject(hfont)
' Liberamos el contexto
lngRet = apiReleaseDC(0&, hDC)
' Devolvemos la longitud de la cadena en Twips
StringToTwips = stfSize.cx * (1440 / GetTwipsPerPixel())
End Function
Private Function GetTwipsPerPixel() As Integer
' Determina cuantos Twips hay en un 1 Pixel
' basado en la actual resolución de pantalla
Dim lngIC As Long
lngIC = apiCreateIC("DISPLAY", vbNullString, _
vbNullString, vbNullString)
' Si la llamada al apiCreateIc no ha fallado,
' tomamos la información que nos interesa.
If lngIC > 0 Then
GetTwipsPerPixel = GetDeviceCaps(lngIC, LOGPIXELSX)
' Liberamos el contexto de información.
apiDeleteDC lngIC
Else
' Si algo ha ido mal, se toma un valor estandar.
GetTwipsPerPixel = 120
End If
End Function
' Esta función lo que hace es ir decrementando
' la frase pasada como parametro en un caracter cada vez
' Cuando la variable frase ya no contiene ningún carácter
' (es igual a ""), pues se vuelve a empezar desde el
' principio.
'
' Juan M. Afán de Ribera (happy) / Marzo 2003
'
Function Marquesina(frase As String) As String
Static fraseTMP As String
If fraseTMP = "" Then
fraseTMP = frase
Else
fraseTMP = Right(fraseTMP, Len(fraseTMP) - 1)
End If
Marquesina = fraseTMP
End Function
'************** FIN CODIGO MODULO *******************
(
geocities.com/es/ensolva/Descargas) (
geocities.com/es/ensolva) (
geocities.com/es)