BitMap from userform

BrettCarr · Mar 22, 2006

Hi Guys,
I am putting together as Little Vba that configures glass shower screens, The user see's glass panels In a user form. Once the user has configured the panel(glass panel) He see's a representation of the panel in the form. How can i get all the labels and bitmaps just in the one frame(the Panel),(not the whole form) and make all the lil bits (labels and bitmaps and so on) in to one Bitmap and paste it into a oreder form???
wich is a spread sheet.
I cannot find anything to even remotly point me in the right direction

Please people any sugestion will be a marked inprovment on where im at

If i can get this right it will be a great help to my company and make us all smile with glee

Legacy 98055 · Mar 22, 2006

So you basically want a screen capture of your frame?

Userform containing Frame1 and CommandButton1. Thanks to Jaafar for helping me on this post.

Download example below.

ScreenCaptureControlOnUserform.zip

Copy this code into your userform:
<table border="1" bgcolor="White"><caption ALIGN=left>Example VBA Code:</caption><tr><td> Private Sub CommandButton1_Click()
 Dim sh As Shape
 Set sh = CaptureWindowToRange(Frame1, [B5], Me.Caption)
 'you can resize and reposition the picture by way of the
 'reference provided with the shape object
 MsgBox sh.Name & " added to range B5"
 End Sub

</td></tr></table>

Copy this code into a standard module:
<table border="1" bgcolor="White"><caption ALIGN=left>Example VBA Code:</caption><tr><td> Option Explicit

 Private Declare Function CreateCompatibleDC Lib "Gdi32" (ByVal hDC As Long) As Long
 Private Declare Function CreateCompatibleBitmap Lib "Gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
 Private Declare Function GetDeviceCaps Lib "Gdi32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
 Private Declare Function GetSystemPaletteEntries Lib "Gdi32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
 Private Declare Function CreatePalette Lib "Gdi32" (lpLogPalette As LOGPALETTE) As Long
 Private Declare Function SelectObject Lib "Gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
 Private Declare Function BitBlt Lib "Gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
 Private Declare Function DeleteDC Lib "Gdi32" (ByVal hDC As Long) As Long
 Private Declare Function GetForegroundWindow Lib "user32" () As Long
 Private Declare Function SelectPalette Lib "Gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
 Private Declare Function RealizePalette Lib "Gdi32" (ByVal hDC As Long) As Long
 Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
 Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
 Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
 Private Declare Function GetDesktopWindow Lib "user32" () As Long
 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
 Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
 Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal imageType As Long, ByVal newWidth As Long, ByVal newHeight As Long, ByVal lFlags As Long) As Long
 Private Declare Function EmptyClipboard Lib "user32" () As Long
 Private Declare Function CloseClipboard Lib "user32" () As Long
 Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
 Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
 Private Declare Function WindowFromPoint Lib "user32" (ByVal xpoint As Long, ByVal ypoint As Long) As Long
 Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

 Private Type PALETTEENTRY
 peRed As Byte
 peGreen As Byte
 peBlue As Byte
 peFlags As Byte
 End Type

 Private Type PicBmp
 Size As Long
 Type As Long
 hBmp As Long
 hPal As Long
 Reserved As Long
 End Type

 Private Type LOGPALETTE
 palVersion As Integer
 palNumEntries As Integer
 palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors.
 End Type

 Private Type GUID
 Data1 As Long
 Data2 As Integer
 Data3 As Integer
 Data4(7) As Byte
 End Type

 Private Type RECT
 Left As Long
 Top As Long
 Right As Long
 Bottom As Long
 End Type

 Private Type POINTAPI
 X As Long
 Y 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 vbSrcCopy As Long = &HCC0020
 Private Const vbPicTypeBitmap As Long = 1
 Private Const LOGPIXELSX = 88
 Private Const LOGPIXELSY = 90
 Private Const IMAGE_BITMAP = 0
 Private Const LR_COPYRETURNORG = &H4
 Private Const CF_BITMAP = 2

 Public Function CaptureWindowToRange(Frame As Frame, Range As Range, UserformCaption As String) As Shape
 Dim FrameHandle As Long
 Dim FrameRect As RECT
 Dim ReturnValue As Long
 Dim UserformHandle As Long
 Dim MyPicHandle As IPictureDisp

 UserformHandle = FindWindow("ThunderDFrame", UserformCaption)
 FrameHandle = GetFrameHandle(Frame, UserformHandle)
 ReturnValue = GetWindowRect(FrameHandle, FrameRect)
 Set MyPicHandle = CaptureWindow(FrameHandle, False, 0, 0, _
 FrameRect.Right - FrameRect.Left, FrameRect.Bottom - FrameRect.Top)

 'KPD-Team 2001
 'URL: http://www.allapi.net/
 'E-Mail: KPDTeam@Allapi.net
 Dim hNew As Long
 hNew = CopyImage(MyPicHandle, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
 OpenClipboard UserformHandle
 EmptyClipboard
 SetClipboardData CF_BITMAP, hNew
 CloseClipboard
 Range(1).Select
 ActiveSheet.Paste
 Set CaptureWindowToRange = ActiveSheet.Shapes(Selection.Name)
 End Function

 Private Function GetFrameHandle(Frame As Frame, UserformHandle As Long) As Long
 Dim className As String
 Dim retValue As Long
 Dim PT As POINTAPI
 Dim LeftInPixels As Long
 Dim TopInPixels As Long

 'thanks to Jaafar on mr.excel.com for this snippet
 LeftInPixels = Frame.Left / PointsPerPixelX
 TopInPixels = Frame.Top / PointsPerPixelY
 PT.X = LeftInPixels
 PT.Y = TopInPixels
 ClientToScreen UserformHandle, PT

 GetFrameHandle = WindowFromPoint(PT.X, PT.Y)
 End Function

 'http://support.microsoft.com/default.aspx?scid=kb;en-us;Q161299
 Private Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As IPictureDisp

 Dim hDCMemory As Long
 Dim hBmp As Long
 Dim hBmpPrev As Long
 Dim r As Long
 Dim hDCSrc As Long
 Dim hPal As Long
 Dim hPalPrev As Long
 Dim RasterCapsScrn As Long
 Dim HasPaletteScrn As Long
 Dim PaletteSizeScrn As Long
 Dim LogPal As LOGPALETTE

 ' Depending on the value of Client get the proper device context.
 If Client Then
 hDCSrc = GetDC(hWndSrc) ' Get device context for client area.
 Else
 hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire
 ' window.
 End If

 ' Create a memory device context for the copy process.
 hDCMemory = CreateCompatibleDC(hDCSrc)
 ' Create a bitmap and place it in the memory DC.
 hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
 hBmpPrev = SelectObject(hDCMemory, hBmp)

 ' Get screen properties.
 RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' capabilities.
 HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' support.
 PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)


 If HasPaletteScrn And (PaletteSizeScrn = 256) Then
 LogPal.palVersion = &H300
 LogPal.palNumEntries = 256
 r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
 hPal = CreatePalette(LogPal)
 ' Select the new palette into the memory DC and realize it.
 hPalPrev = SelectPalette(hDCMemory, hPal, 0)
 r = RealizePalette(hDCMemory)
 End If

 ' Copy the on-screen image into the memory DC.
 r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

 ' Remove the new copy of the on-screen image.
 hBmp = SelectObject(hDCMemory, hBmpPrev)

 ' If the screen has a palette get back the palette that was
 ' selected in previously.
 If HasPaletteScrn And (PaletteSizeScrn = 256) Then
 hPal = SelectPalette(hDCMemory, hPalPrev, 0)
 End If

 ' Release the device context resources back to the system.
 r = DeleteDC(hDCMemory)
 r = ReleaseDC(hWndSrc, hDCSrc)

 ' Call CreateBitmapPicture to create a picture object from the
 ' bitmap and palette handles. Then return the resulting picture
 ' object.
 Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
 End Function

 'http://support.microsoft.com/default.aspx?scid=kb;en-us;Q161299
 Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As IPictureDisp
 Dim r As Long

 Dim Pic As PicBmp
 ' IPicture requires a reference to "Standard OLE Types."
 Dim IPic As IPictureDisp
 Dim IID_IDispatch As GUID

 ' Fill in with IDispatch Interface ID.
 With IID_IDispatch
 .Data1 = &H20400
 .Data4(0) = &HC0
 .Data4(7) = &H46
 End With

 ' Fill Pic with necessary parts.
 With Pic
 .Size = Len(Pic) ' Length of structure.
 .Type = vbPicTypeBitmap ' Type of Picture (bitmap).
 .hBmp = hBmp ' Handle to bitmap.
 .hPal = hPal ' Handle to palette (may be null).
 End With

 ' Create Picture object.
 r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

 ' Return the new Picture object.
 Set CreateBitmapPicture = IPic
 End Function

 ''thanks to Stephen Bullen
 Private Function PointsPerPixelX() As Double
 Dim hDC As Long
 hDC = GetDC(0)
 PointsPerPixelX = 72 / GetDeviceCaps(hDC, LOGPIXELSX)
 ReleaseDC 0, hDC
 End Function

 'thanks to Stephen Bullen
 Private Function PointsPerPixelY() As Double
 Dim hDC As Long
 hDC = GetDC(0)
 PointsPerPixelY = 72 / GetDeviceCaps(hDC, LOGPIXELSY)
 ReleaseDC 0, hDC
 End Function
</td></tr></table>

BitMap from userform

BrettCarr

New Member

Excel Facts

Legacy 98055

Guest

Similar threads

Forum statistics

Share this page

BitMap from userform

BrettCarr

New Member

Excel Facts

Legacy 98055

Guest

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock