AW: mehrere Excel-Dateien als pdf
01.12.2020 06:52:17
Ulrich
Hallo Nepumuk,
gerade alles noch einmal getestet. Klappt alles reibungslos !! wirklich schön.
Vielleicht noch eine Frage.
Die Fotos werden ja mit folgendem Code aufgenommen.
Funktioniert auch alles.
Nun die Frage: ist es möglich, dass das Foto in die Zelle oder dem Zellverbund, auf dem das Steuerelement steht, angepasst an Zellgröße eingestellt wird?
Würde den Ablauf etwas beschleunigen, ist aber auch kein muss.
Ich bin schon happy wie es aktuell läuft.
Gruß Ulli
Option Explicit
Option Private Module
Private Declare PtrSafe 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 LongPtr, _
ByVal nID As Long) As LongPtr
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Any, _
ByRef pCLSID As GUID) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32.dll" ( _
ByVal hWnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32.dll" ( _
ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
ByRef PicDesc As PIC_DESC, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPictureDisp) As Long
Private Declare PtrSafe Function CopyImage Lib "user32.dll" ( _
ByVal handle As LongPtr, _
ByVal un1 As Long, _
ByVal n1 As Long, _
ByVal n2 As Long, _
ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe 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 LongPtr
lnghPal As LongPtr
End Type
Private Const PICTYPE_BITMAP As Long = 1
Private Const CF_BITMAP As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG As Long = &H4
Private Const GC_CLASSNAMEMSUSERFORM As String = "ThunderDFrame"
Private Const WS_CHILD As Long = &H40000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const WM_CAP_START As Long = &H400
Private Const WM_CAP_EDIT_COPY As Long = (WM_CAP_START + 30)
Private Const WM_CAP_DRIVER_CONNECT As Long = (WM_CAP_START + 10)
Private Const WM_CAP_SET_PREVIEWRATE As Long = (WM_CAP_START + 52)
Private Const WM_CAP_SET_OVERLAY As Long = (WM_CAP_START + 51)
Private Const WM_CAP_SET_PREVIEW As Long = (WM_CAP_START + 50)
Private Const WM_CAP_DRIVER_DISCONNECT As Long = (WM_CAP_START + 11)
Private Const WM_CAP_GRAB_FRAME As Long = (WM_CAP_START + 60)
Private Const GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Private llngptrCamHandle As LongPtr
Private llngTries As Long
Private lblnCameraOpen As Boolean
Public gblnCancelDialog As Boolean
Private Sub GrabPicture()
Call SendMessageA(llngptrCamHandle, WM_CAP_GRAB_FRAME, 0&, 0&)
Call SendMessageA(llngptrCamHandle, WM_CAP_EDIT_COPY, 0&, 0&)
End Sub
Public Sub CloseCamera()
Call Unload(Object:=UserForm2)
Call SendMessageA(llngptrCamHandle, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
Call DestroyWindow(llngptrCamHandle)
End Sub
Private Sub OpenCamera(hWndParent As LongPtr, plngWidth As Long, plngHeight As Long)
If Not lblnCameraOpen Then
llngptrCamHandle = capCreateCaptureWindowA("Video", WS_CHILD Or _
WS_VISIBLE, 0&, 0&, plngWidth, plngHeight, hWndParent, 0&)
If SendMessageA(llngptrCamHandle, WM_CAP_DRIVER_CONNECT, 0&, 0&) = 1 Then
gblnCancelDialog = False
Call SendMessageA(llngptrCamHandle, WM_CAP_SET_PREVIEWRATE, 30&, 0&)
Call SendMessageA(llngptrCamHandle, WM_CAP_SET_OVERLAY, 1&, 0&)
Call SendMessageA(llngptrCamHandle, WM_CAP_SET_PREVIEW, 1&, 0&)
Else
gblnCancelDialog = True
End If
End If
End Sub
Private Function Paste_Picture() As IPictureDisp
Dim lngReturn As Long, lngptrCopy As LongPtr, lngptrPointer As LongPtr
If IsClipboardFormatAvailable(CF_BITMAP) 0 Then
lngReturn = OpenClipboard(CLngPtr(Application.hWnd))
If lngReturn = 1 Then
lngptrPointer = GetClipboardData(CF_BITMAP)
lngptrCopy = CopyImage(lngptrPointer, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
Call CloseClipboard
If lngptrPointer 0 Then Set Paste_Picture = Create_Picture(lngptrCopy)
End If
End If
End Function
Private Function Create_Picture( _
ByVal lnghPic As LongPtr) As IPictureDisp
Dim udtPicInfo As PIC_DESC, udtID_IDispatch As GUID
Dim objPicture As IPictureDisp
Call CLSIDFromString(StrPtr(GUID_IPICTUREDISP), udtID_IDispatch)
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
Set objPicture = Nothing
End Function
Public Function GetCameraPicture() As IPictureDisp
Static lngptrHwnd As LongPtr
Dim objPicture As IPictureDisp
Call OpenClipboard(CLngPtr(Application.hWnd))
Call EmptyClipboard
Call CloseClipboard
If Not lblnCameraOpen Then
Load UserForm2
lngptrHwnd = FindWindowA(GC_CLASSNAMEMSUSERFORM, UserForm2.Caption)
Call OpenCamera(lngptrHwnd, 640, 480)
End If
If Not gblnCancelDialog Then
Call GrabPicture
Set objPicture = Paste_Picture
If Not objPicture Is Nothing Then
lblnCameraOpen = True
Set GetCameraPicture = objPicture
Set objPicture = Nothing
llngTries = 0
Else
lblnCameraOpen = False
If llngTries
Public Sub NewPhoto()
UserForm1.Show
End Sub
