AW: Print Microsoft Web Browser Fenster
08.04.2015 14:48:31
Nepumuk
Hallo,
für mal den Webbrowser in ein UserForm ein, so dass die gesamte Fläche des UserForms damit gefüllt ist. In das Modul des UserForms folgenden Code:
' **********************************************************************
' Modul: UserForm1 Typ: Userform
' **********************************************************************
Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLongA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
Private Declare Function DrawMenuBar Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As Long
Private Declare Function IsThemeActive Lib "UxTheme.dll" () As Long
Private Const GC_CLASSNAMEUSERFORM = "ThunderDFrame"
Private Const GWL_STYLE = -16&
Private Const WS_CAPTION = &HC00000
Private Const HTCAPTION = 2&
Private Const WM_NCLBUTTONDOWN = &HA1
Private Sub UserForm_Activate()
Dim udtRectangle As RECT
Dim lngptrForm As LongPtr, lngptrStyle As LongPtr
Call WebBrowser1.Navigate2("http://www.herber.de/forum/")
lngptrForm = FindWindowA(GC_CLASSNAMEUSERFORM, Caption)
If lngptrForm <> 0 Then
lngptrStyle = GetWindowLongA(lngptrForm, GWL_STYLE)
lngptrStyle = lngptrStyle And Not WS_CAPTION
Call SetWindowLongA(lngptrForm, GWL_STYLE, lngptrStyle)
Call DrawMenuBar(lngptrForm)
Height = Height - IIf(Cbool(IsThemeActive), 20, 18)
End If
Do
Call Sleep(100)
DoEvents
Loop While WebBrowser1.Busy
Do
Call Sleep(100)
DoEvents
Loop Until WebBrowser1.ReadyState = READYSTATE_COMPLETE
With udtRectangle
.Left = Left / 0.75
.Top = Top / 0.75
.Right = (Left + Width) / 0.75
.Bottom = (Top + Height) / 0.75
End With
Call Save_Picture(udtRectangle)
Call Unload(Me)
End Sub
In ein Standardmodul kommt folgender Code:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetSystemPaletteEntries Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal wStartIndex As Long, _
ByVal wNumEntries As Long, _
ByRef lpPaletteEntries As PALETTEENTRY) As Long
Private Declare PtrSafe Function CreatePalette Lib "gdi32.dll" ( _
lpLogPalette As LOGPALETTE) As LongPtr
Private Declare PtrSafe Function SelectPalette Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal hPalette As LongPtr, _
ByVal bForceBackground As Long) As LongPtr
Private Declare PtrSafe Function RealizePalette Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function BitBlt Lib "gdi32.dll" ( _
ByVal hDestDC As LongPtr, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As LongPtr, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" ( _
ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Any, _
ByRef pCLSID As GUID) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.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 GetDC Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long, _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Long) 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 Declare PtrSafe Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
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 RASTERCAPS As Long = 38&
Private Const RC_PALETTE As Long = &H100&
Private Const SIZEPALETTE As Long = 104&
Private Const SRCCOPY As Long = &HCC0020
Private Const CF_BITMAP As Long = 2&
Private Const IMAGE_BITMAP As Long = 0&
Private Const LR_COPYRETURNORG As Long = &H4&
Private Const PICTYPE_BITMAP As Long = 1&
Private Const GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Public Sub Save_Picture(ByRef prudtRectangle As RECT)
Dim lngptrCopyHandle As LongPtr
Dim strFileName As String
Dim objPicture As IPictureDisp
Call OpenClipboard(CLngPtr(Application.hwnd))
Call EmptyClipboard
Call SetClipboardData(CF_BITMAP, DC_To_Picture(prudtRectangle))
Call CloseClipboard
Set objPicture = Paste_Picture(lngptrCopyHandle)
If Not objPicture Is Nothing Then
strFileName = ThisWorkbook.Path & "\TempPicture.bmp"
Call SavePicture(objPicture, strFileName)
Set objPicture = Nothing
Call DeleteObject(lngptrCopyHandle)
With Tabelle1
Call .Shapes.AddPicture(strFileName, msoFalse, msoTrue, _
.Cells(3.3).Left, .Cells(3, 3).Top, -1, -1)
End With
Else
Call Err.Raise(Number:=vbObjectError & 1004&, _
Description:="Feher beim Erstellen des Bildes.")
End If
End Sub
Private Function DC_To_Picture( _
ByRef prudtRect As RECT) As LongPtr
Dim lngLeftSrc As Long, lngTopSrc As Long, lngWidthSrc As Long, lngHeightSrc As Long
Dim lngprthDCMemory As LongPtr, lngptrhBmp As LongPtr
Dim lngptrhPal As LongPtr, lngptrhPalPrev As LongPtr, lngptrhBmpPrev As LongPtr
Dim lngRasterCapsScrn As Long, lngptrhDCScr As LongPtr
Dim lngHasPaletteScrn As Long, lngPaletteSizeScrn As Long
Dim udtLogPal As LOGPALETTE
lngLeftSrc = prudtRect.Left
lngTopSrc = prudtRect.Top
lngWidthSrc = prudtRect.Right - prudtRect.Left
lngHeightSrc = prudtRect.Bottom - prudtRect.Top
lngptrhDCScr = GetDC(0)
lngprthDCMemory = CreateCompatibleDC(lngptrhDCScr)
lngptrhBmp = CreateCompatibleBitmap(lngptrhDCScr, lngWidthSrc, lngHeightSrc)
lngptrhBmpPrev = SelectObject(lngprthDCMemory, lngptrhBmp)
lngRasterCapsScrn = GetDeviceCaps(lngptrhDCScr, RASTERCAPS)
lngHasPaletteScrn = lngRasterCapsScrn And RC_PALETTE
lngPaletteSizeScrn = GetDeviceCaps(lngptrhDCScr, SIZEPALETTE)
If lngHasPaletteScrn And (lngPaletteSizeScrn = &H100&) Then
udtLogPal.palVersion = &H300&
udtLogPal.palNumEntries = &H100&
Call GetSystemPaletteEntries(lngptrhDCScr, 0&, _
&H100&, udtLogPal.palPalEntry(0&))
lngptrhPal = CreatePalette(udtLogPal)
lngptrhPalPrev = SelectPalette(lngprthDCMemory, lngptrhPal, 0&)
Call RealizePalette(lngprthDCMemory)
End If
Call BitBlt(lngprthDCMemory, 0&, 0&, lngWidthSrc, lngHeightSrc, _
lngptrhDCScr, lngLeftSrc, lngTopSrc, SRCCOPY)
lngptrhBmp = SelectObject(lngprthDCMemory, lngptrhBmpPrev)
If lngHasPaletteScrn And (lngPaletteSizeScrn = 256&) Then _
lngptrhPal = SelectPalette(lngprthDCMemory, lngptrhPalPrev, 0&)
Call DeleteDC(lngprthDCMemory)
DC_To_Picture = lngptrhBmp
End Function
Private Function Paste_Picture(ByRef prlngptrCopyHandle As LongPtr) As IPictureDisp
Dim lngReturn As Long, lngptrPointer As LongPtr
If Cbool(IsClipboardFormatAvailable(CF_BITMAP)) Then
lngReturn = OpenClipboard(CLngPtr(Application.hwnd))
If lngReturn > 0 Then
lngptrPointer = GetClipboardData(CF_BITMAP)
prlngptrCopyHandle = CopyImage(lngptrPointer, _
IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
Call CloseClipboard
If lngptrPointer <> 0 Then Set Paste_Picture = _
Create_Picture(prlngptrCopyHandle, 0&, CF_BITMAP)
End If
End If
End Function
Private Function Create_Picture( _
ByVal lnghPic As Long, _
ByVal lnghPal As Long, _
ByVal lngPicType As Long) 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 = lnghPal
End With
Call OleCreatePictureIndirect(udtPicInfo, _
udtID_IDispatch, 0&, objPicture)
Set Create_Picture = objPicture
Set objPicture = Nothing
End Function
Starte Das UserForm, es wird das Forum angezeigt und dann ein Bild davon in Zelle C3 eingefügt.
Gruß
Nepumuk
