none
Configurar a resolução da captura da WebCam com o avicap32.dll RRS feed

  • Pergunta

  • Olá,

    Tenho um código que achei na internet que adaptei a um formulário meu, a função básica é tirar fotos e salva-la com os dados do formulário. Porém necessito melhorar a qualidade da imagem que esta em VGA, no entanto tenho uma logitech c270 HD para tirar as fotos que permite resoluções bem melhores. no entando não estou conseguindo melhorar a qualidade da imagem. Será alguém poderia me ajudar?

    ModPastePicture

    '''Tipos definidos pelo usuário para chamadas de API
    
    'Declara um caminho para armazenadar um GUID para o OLE interface IPicture
     Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
    
    'Declara uma UDT para armazenar as informações bitmap
    Private Type uPicDesc
        Size As Long
        Type As Long
        hPic As Long
        hPal As Long
    End Type
    
    '''Windows declarações de função API
    
    'Será que a área de transferência contém um mapa de bits / metafile?
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    
    'Abra a área de transferência para ler
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    
    'Obter um ponto para o bitmap / metafile
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
    
    'Feche a área de transferência
    Private Declare Function CloseClipboard Lib "user32" () As Long
    
    'Converter o identificador em uma interface OLE IPicture.
    Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    
    'Criar nossa própria cópia do metarquivo, para que ele não se dizimado pelas atualizações da área de transferência subsequentes.
    Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
    
    'Criar nossa própria cópia do mapa de bits, por isso não se dizimado por atualizações posteriores da área de transferência.
    Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    
    'Os tipos de formato API que estamos interessados
    Const CF_BITMAP = 2
    Const CF_PALETTE = 9
    Const CF_ENHMETAFILE = 14
    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: PastePicture
    '''
    ''' Purpose:    Obter um objeto de exibição de imagem que quer que esteja na área de transferência.
    '''
    ''' Arguments:  lXlPicType - O tipo de imagem para criar. Pode ser uma das:
    '''                          xlPicture para criar um Metafile (default)
    '''                          xlBitmap para criar um mapa de bits
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 30 Oct 98   Stephen Bullen      Created
    ''' 15 Nov 98   Stephen Bullen      Updated to create our own copies of the clipboard images
    '''
    
    Function PastePicture(Optional lXlPicType As Long) As IPicture
    
    'alguns pontos
    Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
    
    'Converter o tipo de imagem solicitados à constante xl à constante API
    lPicType = IIf(lXlPicType, CF_BITMAP, CF_ENHMETAFILE)
    
    'Verifique se a área de transferência contém o formato exigido
    hPicAvail = IsClipboardFormatAvailable(lPicType)
    
    If hPicAvail <> 0 Then
        'Tenha acesso à área de transferência
        h = OpenClipboard(0&)
    
        If h > 0 Then
            'Obter um identificador para os dados da imagem
            hPtr = GetClipboardData(lPicType)
    
            'Criar nossa própria cópia da imagem na área de transferência, no formato adequado.
            If lPicType = CF_BITMAP Then
                hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Else
                hCopy = CopyEnhMetaFile(hPtr, vbNullString)
            End If
    
            'Solte a área de transferência para outros programas
            h = CloseClipboard
    
            'Se temos um identificador para a imagem, convertê-lo em um objeto de imagem e devolvê-lo
            If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
        End If
    End If
    
    End Function
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: CreatePicture
    '''
    ''' Purpose:    Converte uma imagem (e paleta) lidar em um objeto de imagem.
    '''
    '''             Requer uma referência ao "OLE Automation" biblioteca de tipos
    '''
    ''' Arguments:  Não
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 30 Oct 98  Stephen Bullen      Created
    '''
    
    Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
    
    ' IPicture requer uma referência ao "OLE Automation"
    Dim R As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, iPic As IPicture
    
    'OLE tipos de imagem
    Const PICTYPE_BITMAP = 1
    Const PICTYPE_ENHMETAFILE = 4
    
    ' Crie o GUID Interface (para a interface IPicture)
    With IID_IDispatch
        .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
    
    ' Preencha uPicInfo com peças necessárias.
    With uPicInfo
        .Size = Len(uPicInfo)                                                   ' Comprimento da estrutura.
        .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)  ' Tipo de Imagem
        .hPic = hPic                                                            ' Identificador para imagem.
        .hPal = IIf(lPicType = CF_BITMAP, hPal, 0)                              ' Lidar com a paleta (se bitmap)
    End With
    
    ' Crie o objeto Imagem.
    R = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, iPic)
    
    ' Se ocorreu um erro, mostrar a descrição
    If R <> 0 Then Debug.Print "Create Picture: " & fnOLEError(R)
    
    ' Retorne o novo objeto de imagem
    Set CreatePicture = iPic
    
    End Function
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: fnOLEError
    '''
    ''' Purpose:    Obtém o texto da mensagem para erros OLE padrão
    '''
    ''' Arguments:  None
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 30 Oct 98   Stephen Bullen      Created
    '''
    
    Private Function fnOLEError(lErrNum As Long) As String
    
    'OleCreatePictureIndirect devolver valores
    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
    Const S_OK = &H0
    
    Select Case lErrNum
    Case E_ABORT
        fnOLEError = " Abortado"
    Case E_ACCESSDENIED
        fnOLEError = " Acesso Negado"
    Case E_FAIL
        fnOLEError = " Falha Geral"
    Case E_HANDLE
        fnOLEError = " Bad Handle / faltando"
    Case E_INVALIDARG
        fnOLEError = " Argumento Invalido"
    Case E_NOINTERFACE
        fnOLEError = " Sem interface"
    Case E_NOTIMPL
        fnOLEError = " Não Implementado"
    Case E_OUTOFMEMORY
        fnOLEError = " Sem memória"
    Case E_POINTER
        fnOLEError = " Ponto inválido"
    Case E_UNEXPECTED
        fnOLEError = " Erro Desconhecido"
    Case S_OK
        fnOLEError = " Sucesso!"
    End Select
    
    End Function
    
    


    Formulário

    Public peclac As String
        Public oripec As String
        Public embint As String
        Public chamal As String
        Public avacam As String
        Public avacor As String
        Public nametec As String
        Public NumPec As String
    
    Dim mCapHwnd As Long
    Dim retvale As Long
    Dim CapParms As TCAPTUREPARMS
    Dim Bitmap As Variant 'declaramos uma variável que será o caminho para fotos
    Dim Valeur As Long
    Dim strFormClassName As String
    
    Private Type TCAPTUREPARMS
     dwRequestMicroSecPerFrame As Long
     fLimitEnabled  As Boolean
     fCaptureAudio  As Boolean
     fMCIControl  As Boolean
     fYield  As Boolean
     vKeyAbort As Byte
     fAbortLeftMouse  As Boolean
     fAbortRightMouse As Boolean
    End Type
    
    
    Private Type tagInitCommonControlsEx 'para o Windows XP de efeito
       lngSize As Long
       lngICC As Long
    End Type
    
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
    Private Const ICC_USEREX_CLASSES = &H200
    
    'a constante de saída é 1024
    'video capture calls
    Private Const WM_CAP_DRIVER_CONNECT As Long = 1034          'se a webcam está conectado
    Private Const WM_CAP_GRAB_FRAME As Long = 1084             'para pré-visualizar a webcam
    Private Const WM_CAP_EDIT_COPY As Long = 1054               'para copiar a imagem da webcam, mas aqui ele não funciona porque ele exibe uma prwiev o webcam graças ao copiar e colar (se você encontrar outra coisa para a pré-visualização AC funciona muito bem)
    Private Const WM_CAP_DRIVER_DISCONNECT = 1035               'se a webcam não está conectado
    Private Const WM_CAP_SEQUENCE = 1086                        'AVI para captura
    Private Const WM_CAP_GET_SEQUENCE_SETUP = 1089              'sais pas
    Private Const WM_CAP_SET_SEQUENCE_SETUP = 1088              'sais pas
    Private Const WM_CAP_FILE_SET_CAPTURE_FILE = 1044           'para alterar o caminho de destino do arquivo AVI
    Private Const WM_CAP_DLG_VIDEOSOURCE = 1066                 'para exibir o parâmetro
    Private Const WM_CAP_FILE_SAVEAS = 1047                     'para gravar em um especificador de arquivo
    Private Const WM_CAP_STOP = 1092                            'para parar a captura
    
    
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA" (ByVal lpszWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal nID As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function Sauvegarde Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As String) As Long
    
    Private Sub CommandButton1_Click()
    On Error Resume Next
    
    SendMessage mCapHwnd, WM_CAP_GRAB_FRAME, 0, 0 'imagem da webcam é atualizado"
    SendMessage mCapHwnd, WM_CAP_EDIT_COPY, 0, 0
    DoEvents
    
    Set Image1.Picture = PastePicture(WM_CAP_EDIT_COPY)
    
    End Sub
    
    Private Sub CommandButton2_Click()
    'parâmetros de diálogo WebCam
    SendMessage mCapHwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0
    End Sub
    
    Private Sub CommandButton3_Click()
    Dim iPic As StdPicture
    
    nametec = Label1.Caption
    NumPec = TextBox1.Text
    Debug.Print "nametec", nametec
    Debug.Print "NumPec", NumPec
    
    Set iPic = Me.Image1.Picture
    
    
    If iPic Is Nothing Then Exit Sub
    
    SavePicture iPic, ThisWorkbook.Path _
    & "\fotos\" & Format(Date, "YYYY-MM-DD") & "-" & Format(Time, "HH-MM-SS") & "-" & NumPec & "-" & nametec & ".jpg"
    
    Debug.Print nametec
    
    DestroyIcon iPic.handle
    Set iPic = Nothing
    End Sub
    Private Sub UserForm_Activate()
    If Val(Application.Version) < 9 Then 'Excel 2000
    strFormClassName = "ThunderXFrame"
    Else
    strFormClassName = "ThunderDFrame" 'Excel 2000/2002
    End If
    
    Valeur = FindWindow(strFormClassName, "FomCapWebcam") 'A alça da janela
    
        'definiu-se a variável necessária para o bom funcionamento da captura de vídeo
    mCapHwnd = capCreateCaptureWindow("My Own Capture Window", 0, 0, 0, 1280, 720, Valeur, 0)
        'dizem em prog que câmera está conectada
    SendMessage mCapHwnd, WM_CAP_DRIVER_CONNECT, 0, 0
    
    If SendMessage(mCapHwnd, WM_CAP_DRIVER_CONNECT, 0, 0) = 0 Then
        MsgBox ("A câmera não está conectada")
        retvale = SendMessage(mCapHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0)
        DestroyWindow (mCapHwnd)
    End If
    
    End Sub
    
    
    Private Sub UserForm_Terminate()
    Dim oDataObject As DataObject
    
    'Passo importante antes de sair de outra forma ele pode bloquear!
    retvale = SendMessage(mCapHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0)
    DestroyWindow (mCapHwnd)
    
    Set oDataObject = New DataObject 'vider le presse papier
    oDataObject.SetText ""
    oDataObject.PutInClipboard
    
    Set oDataObject = Nothing
    End Sub
    


    Cristiano Tomadon

    segunda-feira, 2 de fevereiro de 2015 19:24

Todas as Respostas

  • O código está completo?

    Está faltando uma parte, não?

    Por exemplo, onde está a declaração da chamada API FindWindow?


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    terça-feira, 3 de fevereiro de 2015 14:08
    Moderador
  • Obrigado, Felipe.

    Eis o trecho que não havia postado na pergunta.

    Option Explicit
    
    Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    
    Public Declare Function DestroyIcon& Lib "user32" (ByVal hIcon&)


    Cristiano Tomadon

    terça-feira, 3 de fevereiro de 2015 17:09
  • Com um dos botões de comando é possível alterar algumas características da câmera, mas não consegui melhorar a qualidade da imagem também não.

    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 4 de fevereiro de 2015 11:07
    Moderador
  • Estou tentando montar outro código utilizando a biblioteca WIA, mas por enquanto ainda não consegui.

    Segue o código do formulário.

    Option Explicit
    Dim Di As DeviceInfo
    Dim Dev As device
    Private Sub UserForm1_Initialize()
    
        DeviceManager.RegisterEvent wiaEventDeviceConnected
        DeviceManager.RegisterEvent wiaEventDeviceDisconnected
        
        '(1) é o primeiro objecto ligado
        Set Di = DeviceManager.DeviceInfos.Item(1)
        'recupera a conexão ativa
        Set Dev = Di.Connect
        
        If Dev.Type = VideoDeviceType Then
            Set VideoPreview.device = Dev
        End If
    End Sub
    
    Private Sub CommandButton1_Click()
        Dim Itm As Item
        Dim Img As ImageFile
        
        'realiza a captura de imagem
        Set Itm = Dev.ExecuteCommand(wiaCommandTakePicture)
        
        If Not Itm Is Nothing Then
            Set Img = Itm.Transfer
                
                If Not Img Is Nothing Then
                    'exibe a imagem capturada em um objeto "Imagem"
                    Set Image1.Picture = Img.FileData.Picture
                End If
        End If
        
        'para salvar a captura de disco
        'Img.saveFile "C:\monimageTest_WIA_V02.jpg"
    End Sub

    Só que na linha:

     Set Itm = Dev.ExecuteCommand(wiaCommandTakePicture)

    Retorna o erro A variavel do objeto ou a variável do bloco "with" não foi definida.

    Acredito que se eu conseguir com esse código, conseguirei uma foto com uma melhor definição.


    Cristiano Tomadon

    quarta-feira, 4 de fevereiro de 2015 11:55
  • Olá, estou usando este mesmo código, porém quando finalizo a captura da imagem, o formulário (userform) continua rodando, sendo necessário pará-lo.

    Mesmo tendo o módulo Terminate, ela continua funcionando.

    Os senhores poderiam me auxiliar nesta questão?

    Obrigado.


    segunda-feira, 1 de agosto de 2016 23:41
  • Infelizmente, Vanderlei.

    Desisti de utilizar o WIA, por dificuldades de acesso de administrador em ambito empresarial.

    No entando utilizando uma webcam de ponta, consegui ótimos resultados com o avicap.

    Como não terminei de desenvolver em WIA, não posso te ajudar.

    Obrigado.


    Cristiano Tomadon

    quinta-feira, 11 de agosto de 2016 19:35