............ Foro Excel
Si no lo has hecho aún: REGISTRATE!!!

HOLA TENGON UN USERFORM EN EXCEL 2007 Y QUIERO QUE ME APAREZCA LA FOTO

Ver el tema anterior Ver el tema siguiente Ir abajo

HOLA TENGON UN USERFORM EN EXCEL 2007 Y QUIERO QUE ME APAREZCA LA FOTO

Mensaje por victorazul el Jue Oct 08, 2015 1:19 pm

HOLA BUENOS DIAS
TENGO UN USERFORM EN EXCEL 2007 QUE LO TENGO DISEÑADO DE LA SIGUENTE FORMA

Numero Nomina
Codigo Fofo
Nombre
Seccion
Fecha
Hora

lo que intento realizar es que al momento de poner el Numero Nomina me ponga la foto seguin el codigo de foto

el codigo Foto, Nombre, Seccion los jalo de una base existente en el mismo libro pero no me aparece la foto del operario.

y el codigo de la foto la menejo Numero Nomina_primer apellido_segundo apellido y las fotos las tendo en mis imagenes como fotos personal y en el nombre tiene el mismo codigo que en base de datos.

espero me puedan orientar

saludos gracias

victorazul

Masculino Cantidad de envíos : 25
Edad : 45
Ciudad - Pais : Aguascalientes-Mexico
Version de Excel : 2007

Fecha de inscripción : 29/09/2015

Volver arriba Ir abajo

Re: HOLA TENGON UN USERFORM EN EXCEL 2007 Y QUIERO QUE ME APAREZCA LA FOTO

Mensaje por rolano el Sáb Oct 10, 2015 7:05 pm

Prueba con este código:
Código:

Private Sub ComboBox1_Change()
'declaración de variables
Dim RutaImagen As String 'variable que contiene la ruta donde está la imagen
Dim Numero As String 'a esta variable se le asignará
'el numero que se selecciona del ComboBox1
Dim idBusca As String 'busca una coincidencia con Numero
Dim fila As Integer 'variable que comienza en 1 y se incrementa
'hasta que haya  coincidencia con NumeroNomina e idBusca
'se elimina el parpadeo de la pantalla

Application.ScreenUpdating = False
'para que no salte un error si la imágen no existe
On Error Resume Next
fila = 1
Numero = ComboBox1
Hoja1.Range("D6") = Numero

Sheets("personal").Select
Range("IMAGEN").Select
Selection.Copy
  'PastePicture code in Module1 will assign image copied
    'to clipboard, to image control on the form
    Me.Image1.Picture = PastePicture
'se entra en un ciclo Do-While-Loop del que se sale si hay coincidencia
'entre idBusca  y  Numero,  obteniéndose la fila de dicha coincidencia



Do While idBusca <> Numero
    fila = fila + 1
    idBusca = Range("A" & fila).Value
   
Loop
'se hace visible el control Image1
Image1.Visible = True

'se asigna a los TextBox los valores correspondientes de
'la lista que está en la hoja "personal"
TextCodigoFoto = Range("B" & fila).Value
TextNombre = Range("C" & fila).Value
TextDepartamento = Range("D" & fila).Value

'se carga la imagen en el control Image1 ( los nombres de las imágenes
'estan en la colunma 2 o "B")

'Image1.Picture = LoadPicture(RutaImagen & Sheets("personal").Cells(fila, 2) & ".jpg")
If Err.Number <> 0 Then
        'si el archivo jpg no existe, se limpia el
        'error
        Err.Clear
        'se oculta el control Image1
        Image1.Visible = False
    End If

If OptionButton1.Value Then
TextBox1.Value = Format$((Time), "hh:mm")
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""
TextBox6.Value = ""
ElseIf OptionButton2.Value Then
TextBox2.Value = Format$((Time), "hh:mm")
TextBox1.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""
TextBox6.Value = ""
ElseIf OptionButton3.Value Then
TextBox3.Value = Format$((Time), "hh:mm")
TextBox1.Value = ""
TextBox2.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""
TextBox6.Value = ""
ElseIf OptionButton4.Value Then
TextBox4.Value = Format$((Time), "hh:mm")
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox5.Value = ""
TextBox6.Value = ""

ElseIf OptionButton5.Value Then
TextBox5.Value = Format$((Time), "hh:mm")
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox6.Value = ""

ElseIf OptionButton6.Value Then
TextBox6.Value = Format$((Time), "hh:mm")
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""

End If
  ActiveSheet.Cells(1, 1).Copy
  Application.CutCopyMode = False
End Sub

Este código pegalo en un modulo (modulo1)
Código:

        '***************************************************************************
        '*
        '* MODULE NAME:    Paste Picture
        '* AUTHOR & DATE:  STEPHEN BULLEN, Office Automation Ltd
        '*                  15 November 1998
        '*
        '* CONTACT:        [Tienes que estar registrado y conectado para ver este vínculo]
        '* WEB SITE:        http://www.oaltd.co.uk
        '*
        '* DESCRIPTION:    Creates a standard Picture object from whatever is on the clipboard.
        '*                  This object can then be assigned to (for example) and Image control
        '*                  on a userform.  The PastePicture function takes an optional argument of
        '*                  the picture type - xlBitmap or xlPicture.
        '*
        '*                  The code requires a reference to the "OLE Automation" type library
        '*
        '*                  The code in this module has been derived from a number of sources
        '*                  discovered on MSDN.
        '*
        '***************************************************************************

        Option Explicit
        Option Compare Text

        '=================================='
        ' User-Defined Types for API Calls '
        '=================================='

        'Declare the GUID Type structure for the IPicture OLE Interface
        Private Type GUID
            Data1 As Long
            Data2 As Integer
            Data3 As Integer
            Data4(0 To 7) As Byte
        End Type

        'Declare the Picture Description Type structure
        Private Type PICTDESC
            Size As Long
            Type As Long
            hPic As Long    'Holds the handle to a .bmp, .emf, .ico, .wmf file
            Data1 As Long    'For a .bmp this holds the pallete handle hPal. For a .wmf this hold the xExt value.
            Data2 As Long    'Used only with a .wmf to hold the yExt value.
        End Type

        '==================================='
        ' Windows API Function Declarations '
        '==================================='

        'Does the clipboard contain a bitmap/metafile?
        Private Declare Function IsClipboardFormatAvailable _
          Lib "user32.dll" _
            (ByVal wFormat As Integer) As Long

        'Open the clipboard to read and write data
        Private Declare Function OpenClipboard _
          Lib "user32.dll" _
            (ByVal hWnd As Long) As Long

        'Get a pointer to the bitmap/metafile
        Private Declare Function GetClipboardData _
          Lib "user32.dll" _
            (ByVal wFormat As Integer) As Long
           
        'Copy data to the clipboard
        Private Declare Function SetClipboardData _
          Lib "user32.dll" _
            (ByVal uFormat As Long, _
            ByVal hData As Long) As Long
           
        'Empty the clipboard
        Private Declare Function EmptyClipboard _
          Lib "user32.dll" () As Long
         
        'Close the clipboard
        Private Declare Function CloseClipboard _
          Lib "user32.dll" () As Long

        'Convert the handle into an OLE IPicture interface.
        Private Declare Function OleCreatePictureIndirect _
          Lib "olepro32.dll" _
            (ByRef pPictDesc As PICTDESC, _
              ByRef riid As GUID, _
              ByVal fOwn As Long, _
              ByRef ppvObj As IPicture) As Long

        'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
        Declare Function CopyEnhMetaFile _
          Lib "GDI32.dll" _
            Alias "CopyEnhMetaFileA" _
              (ByVal hemfSrc As Long, _
                ByVal lpszFile As String) As Long

        'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
        Declare Function CopyImage _
          Lib "user32.dll" _
            (ByVal hImage As Long, _
              ByVal uType As Long, _
              ByVal cxDesired As Long, _
              ByVal cyDesired As Long, _
              ByVal fuFlags As Long) As Long

        'The API Constants needed
        Const CF_BITMAP = &H2
        Const CF_ENHMETAFILE = &HE
        Const CF_METAFILEPICT = &H3
        Const CF_PALETTE = &H9
        Const IMAGE_BITMAP = &H0
        Const IMAGE_ICON = &H1
        Const IMAGE_CURSOR = &H2
        Const LR_COPYRETURNORG = &H4


        Function PastePicture(Optional xlPicType As Long = xlPicture) As IPicture

          'Some pointers
          Dim hClip As Long
          Dim hCopy As Long
          Dim hObj As Long
          Dim hPal As Long
          Dim hPicAvail As Long
          Dim PicType As Long
          Dim RetVal As Long

          'Convert the Excel picture type constant to the correct API constant
            PicType = IIf(xlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)

          'Check if the clipboard contains the required format
            hPicAvail = IsClipboardFormatAvailable(PicType)

              If hPicAvail <> 0 Then
                'Get access to the clipboard
                hClip = OpenClipboard(0&)

                  If hClip > 0 Then
                    'Get a handle to the object
                    hObj = GetClipboardData(PicType)

                      'Create a copy of the clipboard image in the appropriate format.
                      If PicType = CF_BITMAP Then
                          hCopy = CopyImage(hObj, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
                      Else
                          hCopy = CopyEnhMetaFile(hObj, vbNullString)
                      End If

                    'Release the clipboard to other programs
                    RetVal = CloseClipboard

                    'If there is a handle to the image, convert it into a Picture object and return it
                    If hObj <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, PicType)
                  End If
              End If

        End Function

        Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal PicType) As IPicture

          'IPicture requires a reference to "OLE Automation"
          Dim Ref_ID As GUID
          Dim IPic As IPicture
          Dim PicInfo As PICTDESC
          Dim RetVal As Long

          'OLE Picture types
          Const PICTYPE_UNINITIALIZED = -1 ' The picture object is currently uninitialized.
          Const PICTYPE_NONE = 0          ' A new picture object is to be created without an initialized state. This value is valid only in the PICTDESC structure.
          Const PICTYPE_BITMAP = 1        ' The picture type is a bitmap. When this value occurs in the PICTDESC structure, it means that the bmp field of that structure contains the relevant initialization parameters.
          Const PICTYPE_METAFILE = 2      ' The picture type is a metafile. When this value occurs in the PICTDESC structure, it means that the wmf field of that structure contains the relevant initialization parameters.
          Const PICTYPE_ICON = 3          ' The picture type is an icon. When this value occurs in the PICTDESC structure, it means that the icon field of that structure contains the relevant initialization parameters.
          Const PICTYPE_ENHMETAFILE = 4    ' The picture type is a Win32-enhanced metafile. When this value occurs in the PICTDESC structure, it means that the emf field of that structure contains the relevant initialization parameters.

          'Create a UDT to hold the reference to the interface ID (riid).
          'IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
          'StdPicture GUID {0BE35204-8F91-11CE-9DE3-00AA004BB851}
          With Ref_ID
            .Data1 = &H7BF80980
            .Data2 = &HBF32
            .Data3 = &H101A
            .Data4(0) = &H8B
            .Data4(1) = &HBB
            .Data4(2) = &H0
            .Data4(3) = &HAA
            .Data4(4) = &H0
            .Data4(5) = &H30
            .Data4(6) = &HC
            .Data4(7) = &HAB
          End With

          'Fill PicInfo structure
          With PicInfo
            .Size = Len(PicInfo)                                                    ' Length of structure.
            .Type = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)  ' Type of Picture
            .hPic = hPic                                                            ' Handle to image.
            .Data1 = IIf(PicType = CF_BITMAP, hPal, 0&)                            ' Handle to palette (if bitmap).
            .Data2 = 0&
          End With

            'Create the Picture object.
            RetVal = OleCreatePictureIndirect(PicInfo, Ref_ID, True, IPic)

              'Check if an error ocurred
              If RetVal <> 0 Then
                  MsgBox "Create Picture Failed - " & GetErrMsg(RetVal)
                  Set IPic = Nothing
                  Exit Function
              End If

            'Return the new Picture object.
            Set CreatePicture = IPic

        End Function

        Private Function GetErrMsg(ErrNum As Long) As String

          'OLECreatePictureIndirect return values
          Const E_ABORT = &H80004004
          Const E_ACCESSDENIED = &H80070005
          Const E_FAIL = &H80004005
          Const E_HANDLE = &H80070006
          Const E_INVALIDARG = &H80070057
          Const E_NOINTERFACE = &H80004002
          Const E_NOTIMPL = &H80004001
          Const E_OUTOFMEMORY = &H8007000E
          Const E_POINTER = &H80004003
          Const E_UNEXPECTED = &H8000FFFF

            Select Case ErrNum
              Case E_ABORT
                GetErrMsg = " Aborted"
              Case E_ACCESSDENIED
                GetErrMsg = " Access Denied"
              Case E_FAIL
                GetErrMsg = " General Failure"
              Case E_HANDLE
                GetErrMsg = " Bad/Missing Handle"
              Case E_INVALIDARG
                GetErrMsg = " Invalid Argument"
              Case E_NOINTERFACE
                GetErrMsg = " No Interface"
              Case E_NOTIMPL
                GetErrMsg = " Not Implemented"
              Case E_OUTOFMEMORY
                GetErrMsg = " Out of Memory"
              Case E_POINTER
                GetErrMsg = " Invalid Pointer"
              Case E_UNEXPECTED
                GetErrMsg = " Unknown Error"
            End Select

        End Function


_________________
Saludos,
César Tirado
M.A.P. 2012-2014
Microsoft Active Professional
[Tienes que estar registrado y conectado para ver este vínculo]
avatar
rolano
Moderador
Moderador

Masculino Cantidad de envíos : 53
Edad : 44
Fecha de inscripción : 14/04/2009

http://excelilove.blogspot.com/

Volver arriba Ir abajo

Re: HOLA TENGON UN USERFORM EN EXCEL 2007 Y QUIERO QUE ME APAREZCA LA FOTO

Mensaje por victorazul el Lun Oct 12, 2015 7:52 pm

gracias Cesar

si es lo que necesito

muchas gracias

victorazul

Masculino Cantidad de envíos : 25
Edad : 45
Ciudad - Pais : Aguascalientes-Mexico
Version de Excel : 2007

Fecha de inscripción : 29/09/2015

Volver arriba Ir abajo

Re: HOLA TENGON UN USERFORM EN EXCEL 2007 Y QUIERO QUE ME APAREZCA LA FOTO

Mensaje por victorazul el Mar Oct 13, 2015 7:07 pm

Hola Cesar

si es lo que quiero realizar ahora dejame abrir otro tema

saludos gracias.

victorazul

Masculino Cantidad de envíos : 25
Edad : 45
Ciudad - Pais : Aguascalientes-Mexico
Version de Excel : 2007

Fecha de inscripción : 29/09/2015

Volver arriba Ir abajo

Re: HOLA TENGON UN USERFORM EN EXCEL 2007 Y QUIERO QUE ME APAREZCA LA FOTO

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Ver el tema anterior Ver el tema siguiente Volver arriba


 
Permisos de este foro:
No puedes responder a temas en este foro.