Macros de excel para web cam

¿Me podrías pasar el archivo de dropbox que responde a esta pregunta?
https://www.dropbox.com/s/23z6eezfmn3y3ri/tomar%20foto%20webcam5.xlsm 
me dice que el enlace esta inhabilitado

1 Respuesta

Respuesta
2

Estas son las macros de ese archivo

Dim htmp As String
Dim fichero As String
Const fgif = "foto"
Const mipath = "c:\" 'debe acabar en \ el directorio donde guardar las fotos
'
Private Sub CommandButton2_Click()
' Por.Dante Amor
    uf = Range("A" & Rows.Count).End(xlUp).Row + 1
    Range("A" & uf) = TextBox1
    Range("B" & uf) = TextBox2
    Range("C" & uf).Select
    ActiveSheet.Pictures.Insert(fichero).Select
    '
    With Selection
        .Placement = xlFreeFloating
        .PrintObject = True
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 115#
        .ShapeRange.Width = 99#
        .ShapeRange.Rotation = 0#
        .ShapeRange.Left = Range("C" & uf).Left
        .ShapeRange.Top = Range("C" & uf).Top
    End With
End Sub
'
Private Sub CommandButton1_Click()
'Actualizado, Por.Dante Amor
    Dim s As Shape
    'Crea la hoja para guardar temporalmente la foto
    Application.ScreenUpdating = False
    Sheets.Add
    htmp = ActiveSheet.Name
    Sheets(htmp).Select
    Sheets(htmp).ChartObjects.Add(0, 0, 200, 250).Name = fgif
    Application.CommandBars.FindControl(ID:=1764).Execute
    'es necesaria una hoja creada al inicio para la captura
    'al grabar se crea una copia en la hoja que es un shape
    Selection.Copy
    Sheets(htmp).ChartObjects(fgif).Activate
    ActiveChart.ChartArea.Select
    ActiveChart.Paste
    'En esta parte se guarda el nombre de la foto, _
    puedes cambiar el texto "num-inscripcion" por un valor
    fichero = mipath & "num-inscripcion" & ".gif"
    ActiveChart.Export Filename:=fichero 'graba en disco la foto
    Me.Image1.Picture = LoadPicture(fichero)
    'limpio la foto pegada y el chart
    For Each s In Sheets(htmp).Shapes
        s.Delete
    Next s
    'Borra hoja temporal
    Application.DisplayAlerts = False
    Worksheets(htmp).Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Tienes que crear un formulario con estos controles: 2 textbox, un image, 2 commandbutton


en módulo pon lo siguiente:

Sub frmfoto()
UserForm1.Show
End Sub

Envíame un correo para enviarte el archivo.

Mi correo [email protected]

En el asunto del correo escribe tu nombre de usuario “Juan Manuel Rios” y el título de esta pregunta.

S a l u d o s . D a n t e   A m o r

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas