Ejemplo de Control ActiveX (gsImage.ocx)
La función de esta página es
para que se instale en tu equipo.
Sólo
funciona con Internet Explorer 3 o superior y Netscape con algún
plug-in (creo).
Actualizado: 20/May/97
Revisado 8-Jul-97
Otra prueba
(aunque realmente no es tan "prueba"), para poder
usarlo con VB4.
Este control admite los formatos GIF y JPG. Se puede usar sin
problemas con VB4 de 32 bits.
Bajate los listados del control y los ejemplos para VB4 y VB5 (cualquier edición) (gsImage.zip 26.1KB)
Este control no tiene
prácticamente ningún misterio, casi lo único que hace es tomar
el control Image que incorpora VB5 y al estar compilado como
control ActiveX, puedes usarlo en tus proyectos de VB4 (32 bits)
De esta forma dispondrás de un control Image que puede cargar
archivos del tipo GIF y JPG.
Si quieres obtener los listados
del control, así como un form de prueba, pulsa en el link que
hay arriba.
Este control puedes usarlo en cualquier VB de 32bits, para
modificarlo sólo en VB5cce y demás versiones de pago.
Para ver los diferentes listados, pulsa en estos links:
|
'----------------------------------------------------------------- 'Control de Imagen, para usar con VB4 (20/May/97) '----------------------------------------------------------------- Option Explicit 'Event Declarations: Event Click() 'MappingInfo=Image1,Image1,-1,Click Attribute Click.VB_Description = "Ocurre cuando el usuario presiona y libera un botón del mouse encima de un objeto." Event DblClick() 'MappingInfo=Image1,Image1,-1,DblClick Attribute DblClick.VB_Description = "Ocurre cuando el usuario presiona y suelta un botón del mouse y lo vuelve a presionar y soltar sobre un objeto." Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyDown Event KeyPress(KeyAscii As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyPress Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyUp Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Image1,Image1,-1,MouseDown Attribute MouseDown.VB_Description = "Ocurre cuando el usuario presiona el botón del mouse mientras un objeto tiene el enfoque." Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Image1,Image1,-1,MouseMove Attribute MouseMove.VB_Description = "Ocurre cuando el usuario mueve el mouse." Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Image1,Image1,-1,MouseUp Attribute MouseUp.VB_Description = "Ocurre cuando el usuario suelta el botón del mouse mientras un objeto tiene el enfoque." ' Cargar valores de propiedades desde el almacenamiento Private Sub UserControl_ReadProperties(PropBag As PropertyBag) On Local Error Resume Next Image1.BorderStyle = PropBag.ReadProperty("BorderStyle", 0) Set Picture = PropBag.ReadProperty("Picture", Nothing) Image1.Enabled = PropBag.ReadProperty("Enabled", True) Image1.Stretch = PropBag.ReadProperty("Stretch", False) ToolTipText = PropBag.ReadProperty("ToolTipText", "") Err = 0 End Sub Private Sub UserControl_Resize() Static YaEstoy As Boolean If YaEstoy Then Exit Sub YaEstoy = True With Image1 If .Stretch = False Then Height = .Height Width = .Width Else .Height = Height .Width = Width End If End With YaEstoy = False 'Image1.ToolTipText = Extender.ToolTipText End Sub ' Escribir valores de propiedades en el almacenamiento Private Sub UserControl_WriteProperties(PropBag As PropertyBag) On Local Error Resume Next Call PropBag.WriteProperty("BorderStyle", Image1.BorderStyle, 0) Call PropBag.WriteProperty("Picture", Picture, Nothing) Call PropBag.WriteProperty("Enabled", Image1.Enabled, True) Call PropBag.WriteProperty("Stretch", Image1.Stretch, False) Call PropBag.WriteProperty("ToolTipText", ToolTipText, "") Err = 0 End Sub '¡ADVERTENCIA! NO QUITAR O MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS! 'MappingInfo=Image1,Image1,-1,Enabled Public Property Get Enabled() As Boolean Attribute Enabled.VB_Description = "Devuelve o establece un valor que determina si un objeto puede responder a eventos generados por el usuario." Enabled = Image1.Enabled End Property Public Property Let Enabled(ByVal New_Enabled As Boolean) Image1.Enabled() = New_Enabled PropertyChanged "Enabled" End Property '¡ADVERTENCIA! NO QUITAR O MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS! 'MappingInfo=Image1,Image1,-1,Picture Public Property Get Picture() As Picture Attribute Picture.VB_Description = "Devuelve o establece el gráfico que se mostrará en un control." Set Picture = Image1.Picture End Property Public Property Set Picture(ByVal New_Picture As Picture) Set Image1.Picture = New_Picture PropertyChanged "Picture" UserControl_Resize End Property Public Property Let Picture(ByVal New_Picture As Picture) Set Image1.Picture = New_Picture PropertyChanged "Picture" UserControl_Resize End Property '¡ADVERTENCIA! NO QUITAR O MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS! 'MappingInfo=Image1,Image1,-1,Appearance Public Property Get Appearance() As Integer Attribute Appearance.VB_Description = "Devuelve o establece si los objetos se dibujan en tiempo de ejecución con efectos 3D." Appearance = Image1.Appearance End Property '¡ADVERTENCIA! NO QUITAR O MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS! 'MappingInfo=Image1,Image1,-1,BorderStyle Public Property Get BorderStyle() As Integer Attribute BorderStyle.VB_Description = "Devuelve o establece el estilo del borde de un objeto." BorderStyle = Image1.BorderStyle End Property Public Property Let BorderStyle(ByVal New_BorderStyle As Integer) Image1.BorderStyle() = New_BorderStyle PropertyChanged "BorderStyle" End Property '¡ADVERTENCIA! NO QUITAR O MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS! 'MappingInfo=UserControl,UserControl,-1,Refresh Public Sub Refresh() Attribute Refresh.VB_Description = "Obliga a volver a dibujar un objeto." UserControl.Refresh End Sub Private Sub Image1_Click() RaiseEvent Click End Sub Private Sub Image1_DblClick() RaiseEvent DblClick End Sub Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer) RaiseEvent KeyDown(KeyCode, Shift) End Sub Private Sub UserControl_KeyPress(KeyAscii As Integer) RaiseEvent KeyPress(KeyAscii) End Sub Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer) RaiseEvent KeyUp(KeyCode, Shift) End Sub Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseDown(Button, Shift, X, Y) End Sub Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseMove(Button, Shift, X, Y) End Sub Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseUp(Button, Shift, X, Y) End Sub '¡ADVERTENCIA! NO QUITAR O MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS! 'MappingInfo=Image1,Image1,-1,Stretch Public Property Get Stretch() As Boolean Attribute Stretch.VB_Description = "Devuelve o establece un valor que determina si un gráfico cambia su tamaño para ajustarse al tamaño de un control Image." Stretch = Image1.Stretch End Property Public Property Let Stretch(ByVal New_Stretch As Boolean) Image1.Stretch = New_Stretch PropertyChanged "Stretch" UserControl_Resize End Property Public Property Get ToolTipText() As String ToolTipText = Image1.ToolTipText End Property Public Property Let ToolTipText(ByVal New_ToolTipText As String) Image1.ToolTipText = New_ToolTipText PropertyChanged "ToolTipText" End Property
El listado del Form de Prueba
Con un poco de Drag & Drop, para que no quede la cosa
demasiado "sosa"
El form tiene un CommandButton y un CheckBox, además del control
de marras.
'-------------------------------------------------------------- 'Prueba para el control gsImage (20/May/97) 'Para VB5 y VB4 '-------------------------------------------------------------- Option Explicit Dim sImg1$(1 To 2) Dim iImg% Dim x1&, y1& Dim iDrag% Private Sub Command1_Click() iImg = iImg + 1 If iImg > 2 Then iImg = 1 End If gsImage1.Picture = LoadPicture(sImg1(iImg)) End Sub Private Sub Check1_Click() gsImage1.Stretch = Check1.Value End Sub Private Sub Form_DragDrop(Source As Control, X As Single, Y As Single) Source.Left = X - x1 Source.Top = Y - y1 Source.Drag vbEndDrag End Sub Private Sub Form_Load() iImg = 0 'Pon aquí las imagenes que prefieras sImg1(1) = "ActiveXanim.gif" sImg1(2) = "D:\Webs\guiller\Imagenes\el_guille.jpg" Command1_Click End Sub Private Sub Form_Unload(Cancel As Integer) Set Form1 = Nothing End Sub Private Sub gsImage1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 1 Then x1 = X y1 = Y iDrag = True gsImage1.Drag End If End Sub Private Sub gsImage1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 1 Then ' Else iDrag = False gsImage1.Drag vbCancel End If End Sub Private Sub gsImage1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) iDrag = False gsImage1.Drag vbCancel End Sub
En esta Revisión, lo que he hecho
ha sido volver a comprobar el buen funcionamiento del control en
VB4-32 bits y de camino le he añadido al form de prueba un par
de cosillas más, por ejemplo poder abrir una nueva imagen y
también poder guardar la imagen actual como BMP, que es el
único formato que permite el VB con la orden SavePicture, al
menos el único formato que funciona.
He añadido tres imagenes de muestra, para que puedas probar sin
problemas, por eso el archivo ZIP es más grande de la cuenta. El
control sigue siendo el mismo, no ha cambiado.
Recuerda que el VB no espera que se pueda añadir a un archivo de
Imagen archivos del tipo GIF ni JPG, así que si desde el cuadro
de propiedades vas a añadir alguna imagen, esta deberás
seleccionarla con All Files (*.*).
Aquí tienes el listado de las nuevas "ordenes" y un link para el listado de ejemplo. (t4_gsImg.zip 33.1 KB)
'Esto hay que añadirlo/sustituir en las declaraciones del Form Dim numImage As Integer Dim sImg1$() 'Antes era Dim sImg1$(1 To 2) 'Un botón para examinar y abrir una nueva imagen ' Private Sub cmdExaminar_Click() 'Seleccionar una nueva imagen On Local Error Resume Next With CommonDialog1 .Filter = "Imagenes (*.gif; *.jpg; *.bmp; *.wmf)|*.gif; *.jpg; *.bmp; *.wmf|Todos los archivos (*.*)|*.*" .filename = Text1 .ShowOpen If Err = 0 Then Text1 = .filename numImage = numImage + 1 'Con Redim Preserve mantenemos en memoria los valores anteriores ReDim Preserve sImg1(numImage) sImg1(numImage) = Text1 iImg = numImage 'La mostramos... gsImage1.Picture = LoadPicture(sImg1(iImg)) End If End With Err = 0 On Local Error GoTo 0 End Sub 'Este botoncito es el que nos permite guardar la imagen actual ' Private Sub cmdGuardar_Click() 'Guardar la imagen actual Dim bSalvar As Boolean On Local Error Resume Next With CommonDialog1 .Filter = "BMP (*.bmp)|*.bmp|Todos los archivos (*.*)|*.*" .filename = Text1 .ShowSave bSalvar = False If Err = 0 Then Text1 = .filename bSalvar = True If Len(Dir$(Text1.Text)) Then If MsgBox("Ese archivo ya existe, ¿lo quieres sobrescribir?", vbYesNo) = vbNo Then bSalvar = False End If End If If bSalvar Then SavePicture gsImage1.Picture, Text1.Text End If End If End With Err = 0 On Local Error GoTo 0 End Sub 'Así es como debe quedar el Command1_Click 'para que roten las imagenes añadidas ' Private Sub Command1_Click() iImg = iImg + 1 If iImg > numImage Then iImg = 1 End If gsImage1.Picture = LoadPicture(sImg1(iImg)) Text1 = sImg1(iImg) End Sub 'Este es el nuevo Form_Load 'Las imagenes están en el archivo comprimido que se acompaña con esta nueva revisión ' Private Sub Form_Load() numImage = 3 ReDim sImg1(1 To numImage) iImg = 0 sImg1(1) = "guille3.jpg" sImg1(2) = "ActiveXanim.gif" sImg1(3) = "el_guille.jpg" MostrarTip = 0 Command1_Click End Sub