Inquiridor
Configurar a resolução da captura da WebCam com o avicap32.dll

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
Todas as Respostas
-
-
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
-
-
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
-
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.
- Editado Valderei Antunes 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