Foto aus Userform abspeichern
04.09.2016 08:10:41
Oliver
folgender Code nimmt ein Bild über die Webcam auf (danke Nepumuk aus dem Jahr 2012). Nun möchte ich jedoch das das aufgenommene Bild auch noch abgespeichert wird.
Kann mir jemand helfen. Mit welchem Code kann ich das aufgenommene Bild abspeichern lassen.
Vielen Dank im Voraus.
Oliver
HIER DER CODE:
Option Explicit
Private Declare Function capCreateCaptureWindowA Lib "avicap32.dll" ( _
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 SendMessageA Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function DestroyWindow Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Private Declare Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
ByRef PicDesc As PIC_DESC, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPictureDisp) As Long
Declare Function CopyImage Lib "user32.dll" ( _
ByVal handle As Long, _
ByVal un1 As Long, _
ByVal n1 As Long, _
ByVal n2 As Long, _
ByVal un2 As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Integer) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PIC_DESC
lngSize As Long
lngType As Long
lnghPic As Long
lnghPal As Long
End Type
Private Const PICTYPE_BITMAP = 1
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const GC_CLASSNAMEMSUSERFORM = "ThunderDFrame"
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WM_CAP_START = &H400
Private Const WM_CAP_EDIT_COPY = (WM_CAP_START + 30)
Private Const WM_CAP_DRIVER_CONNECT = (WM_CAP_START + 10)
Private Const WM_CAP_SET_PREVIEWRATE = (WM_CAP_START + 52)
Private Const WM_CAP_SET_OVERLAY = (WM_CAP_START + 51)
Private Const WM_CAP_SET_PREVIEW = (WM_CAP_START + 50)
Private Const WM_CAP_DRIVER_DISCONNECT = (WM_CAP_START + 11)
Private Const WM_CAP_GRAB_FRAME = (WM_CAP_START + 60)
Private llngCamHandle As Long
Private Sub GrabPicture()
Call SendMessageA(llngCamHandle, WM_CAP_GRAB_FRAME, 0&, 0&)
Call SendMessageA(llngCamHandle, WM_CAP_EDIT_COPY, 0&, 0&)
End Sub
Private Sub CloseCamera()
Call SendMessageA(llngCamHandle, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
Call DestroyWindow(llngCamHandle)
End Sub
Private Function OpenCamera(hWndParent As Long, plngWidth As Long, plngHeight As Long) As _
Boolean
On Error GoTo error_handler
llngCamHandle = capCreateCaptureWindowA("Video", WS_CHILD Or _
WS_VISIBLE, 0&, 0&, plngWidth, plngHeight, hWndParent, 11011&)
Call SendMessageA(llngCamHandle, WM_CAP_DRIVER_CONNECT, 0&, 0&)
Call SendMessageA(llngCamHandle, WM_CAP_SET_PREVIEWRATE, 30&, 0&)
Call SendMessageA(llngCamHandle, WM_CAP_SET_OVERLAY, 1&, 0&)
Call SendMessageA(llngCamHandle, WM_CAP_SET_PREVIEW, 1&, 0&)
OpenCamera = True
Exit Function
error_handler:
End Function
Private Function Paste_Picture() As IPictureDisp
Dim lngReturn As Long, lngCopy As Long, lngPointer As Long
If IsClipboardFormatAvailable(CF_BITMAP) 0 Then
lngReturn = OpenClipboard(Application.hWnd)
If lngReturn > 0 Then
lngPointer = GetClipboardData(CF_BITMAP)
lngCopy = CopyImage(lngPointer, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
Call CloseClipboard
If lngPointer 0 Then Set Paste_Picture = Create_Picture(lngCopy)
End If
End If
End Function
Private Function Create_Picture( _
ByVal lnghPic As Long) As IPictureDisp
Dim udtPicInfo As PIC_DESC, udtID_IDispatch As GUID
Dim objPicture As IPictureDisp
With udtID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With udtPicInfo
.lngSize = Len(udtPicInfo)
.lngType = PICTYPE_BITMAP
.lnghPic = lnghPic
.lnghPal = 0
End With
Call OleCreatePictureIndirect(udtPicInfo, udtID_IDispatch, 0&, objPicture)
Set Create_Picture = objPicture
End Function
Public Sub GetCameraPicture()
Dim lngHwnd As Long
Dim objPicture As IPictureDisp
Call EmptyClipboard
Load UserForm1
lngHwnd = FindWindowA(GC_CLASSNAMEMSUSERFORM, UserForm1.Caption)
If OpenCamera(lngHwnd, UserForm1.Width, UserForm1.Height) Then
Call GrabPicture
Call CloseCamera
Set objPicture = Paste_Picture
If Not objPicture Is Nothing Then
Set UserForm1.Image1.Picture = objPicture
UserForm1.Show
Else
MsgBox "Error - Webcam can't show in Userform", vbCritical, "Error"
End If
Else
Unload UserForm1
End If
End Sub