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
