AW: Foto schießen in Userform importieren
04.01.2019 22:13:14
Marco
Die .dll s sieht man oben. Hier der Code:
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 lintTries As Integer
Private lblnCameraOpen As Boolean
Private Sub GrabPicture()
Call SendMessageA(llngCamHandle, WM_CAP_GRAB_FRAME, 0&, 0&)
Call SendMessageA(llngCamHandle, WM_CAP_EDIT_COPY, 0&, 0&)
End Sub
Public Sub CloseCamera()
Call SendMessageA(llngCamHandle, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
Call DestroyWindow(llngCamHandle)
End Sub
Private Sub OpenCamera(hWndParent As Long, plngWidth As Long, plngHeight As Long)
If Not lblnCameraOpen Then
On Error GoTo error_handler
llngCamHandle = capCreateCaptureWindowA("Video", WS_CHILD Or _
WS_VISIBLE, 0&, 0&, plngWidth, plngHeight, hWndParent, 0&)
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&)
Exit Sub
End If
error_handler:
End Sub
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(pic As Image)
Dim lngHwnd As Long
Dim objPicture As IPictureDisp
Call OpenClipboard(0&)
Call EmptyClipboard
Call CloseClipboard
If Not lblnCameraOpen Then
lngHwnd = FindWindowA(GC_CLASSNAMEMSUSERFORM, UserForm2.Caption)
Call OpenCamera(lngHwnd, 320, 240)
End If
Call GrabPicture
Set objPicture = Paste_Picture
If Not objPicture Is Nothing Then
lblnCameraOpen = True
Set pic.Picture = objPicture
lintTries = 0
Else
lblnCameraOpen = False
If lintTries