Re: Create picture in memory and move to a specific hdc

Tech-Archive recommends: Repair Windows Errors & Optimize Windows Performance

From: Alessio Biscucci (corporate_at_miazienda.com)
Date: 12/22/04 

Date: Wed, 22 Dec 2004 14:52:43 +0100

Mike,
my test doesn't produce good results. Certainly it's because
of me. I don't have a lot of experience with graphic's programming.

Here what I tried to do.

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal
nIndex As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x
As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop 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 CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long)
As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long,
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long,
ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal
nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal
nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean,
ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal
fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision
As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal
lpszFace As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As
Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal
nCount As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal
nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal
nBkMode As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As
Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As
RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As
Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Dim mypicture as StdPicture

Private Sub Form_Load()

    Dim Message = "Demo Version"
    Dim mDC As Long, mBitmap As Long
    Dim mRGN As Long, Cnt As Long, mBrush As Long, R As RECT

    'Create a device context, compatible with the screen
    mDC = CreateCompatibleDC(GetDC(0))

    'Create a bitmap, compatible with the screen
    mBitmap = CreateCompatibleBitmap(GetDC(0), Me.Width /
Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY)

    'Select the bitmap nito the device context
    SelectObject mDC, mBitmap

    'Set the bitmap's backmode to transparent
    SetBkMode mDC, TRANSPARENT

    'Set the rectangles' values
    SetRect R, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height /
Screen.TwipsPerPixelY

    'Fill the rect with the default window-color
    FillRect mDC, R, GetSysColorBrush(COLOR_WINDOW)

    'Select the new font into the form's device context and delete the old
font
    DeleteObject SelectObject(mDC, CreateMyFont(24, Cnt))

    'Print some text
    TextOut mDC, 0, 0, Message, Len(Message)

    mypicture = GDIToPicture(mDC)

    picture1.picture = mypicture
End Sub

Function CreateMyFont(nSize As Integer, nDegrees As Long) As Long
    'Create a specified font
    CreateMyFont = CreateFont(-MulDiv(nSize, GetDeviceCaps(GetDC(0),
LOGPIXELSY), 72), 0, nDegrees * 10, 0, FW_NORMAL, False, False, False,
DEFAULT_CHARSET, OUT_DEFAULT_PRECIS,
CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, "Verdana")
End Function

Relevant Pages

  • Logical window to viewport mapping
    ... Private Declare Function SaveDC Lib "gdi32" (ByVal hdc As Long) As Long ...
    (microsoft.public.vb.winapi.graphics)
  • Re: GDI/Screen capture
    ... > lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As> String, ByVal lpInitData As String) As Integer> Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As> Integer) As Integer ...
    (microsoft.public.dotnet.framework.drawing)
  • Metafile Problem Word 2003/VB6
    ... Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As ... Private Declare Function CreateEnhMetaFile Lib "gdi32" Alias _ ... Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ...
    (microsoft.public.word.vba.general)
  • Metafile paste problem
    ... Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As ... Private Declare Function CreateEnhMetaFile Lib "gdi32" Alias _ ... Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ...
    (microsoft.public.vb.winapi.graphics)
  • Re: Problems with proven code after machine rebuild
    ... Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ... Private Declare Function DeleteObject Lib "gdi32" As ...
    (microsoft.public.vb.winapi)