Solved

Copy TextBox Text as a picture

Posted on 1999-01-06
25
347 Views
Last Modified: 2008-03-06
I need to take the text that is displayed in a textbox or in a label as a picture so I can put it into a picturebox. I don't want to use the Print method since it will not word warp and format the alignment etc...

Any Ideas?
0
Comment
Question by:DanAvni
  • 8
  • 7
  • 3
  • +5
25 Comments
 
LVL 14

Expert Comment

by:waty
ID: 1454223
Here is code I use in my Print Preview ocx (see in my profile)
to wordwrap text. But still use the print method.
If you need further information, let me know. Take a look at the Print Preview

Private Function GetWordWrap(sText As String, nStart As Integer, nEnd As Integer) As String
   ' *** Get a specific line in all the text
   
   Dim nI            As Integer
   Dim nPos          As Integer
   Dim sTmp          As String
   Dim sChar         As String
   Dim nAllSpace     As Long
   Dim nText         As Long
   
   ' *** Calculate all the needed space
   nAllSpace = Width - MarginWidth() * 2 - previewLine.nCurrentX
   
   sTmp = ""
   
   ' *** Begin at the end
   For nI = nEnd To nStart Step -1
      sChar = Mid(sText, nI, 1)
      If (sChar = " " Or sChar = "-" Or sChar = Chr$(13) Or sChar = "." Or sChar = ",") Then
         sTmp = Mid(sText, nStart, Len(sText) - nStart - (nEnd - nI) + 1)
         nText = TextWidthPreview(sTmp)
         If (nText < nAllSpace) Then
            ' *** Ok, Found it
            Exit For
         End If
      End If
   Next

   nStart = nStart + Len(sTmp)
   
   GetWordWrap = sTmp
   
End Function


0
 
LVL 13

Expert Comment

by:Mirkwood
ID: 1454224
Hmmm, word wrap is fine. But I think he asked for printing on a picture


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 Sub Command1_Click()
    TextOut Picture1.hdc, 0, 0, "Hello", 5
End Sub

0
 
LVL 2

Author Comment

by:DanAvni
ID: 1454225
Since I want to use it with hebrew (written from right to left) I can't use the preview code you sent. I need some way to copy the text (something lie BitBLT from a Label or TextBox to a picturee box. The problem is that neither have HDC property).
0
 
LVL 14

Expert Comment

by:waty
ID: 1454226
After wordwrapping, he could print using picture1.print or your solution Mirkwood.
0
 
LVL 13

Expert Comment

by:Mirkwood
ID: 1454227
Here is some code to copy from a label to a picture.

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 Sub Command1_Click()
    TextOut Picture1.hdc, 0, 0, label1.text, len(label1.text)
End Sub

0
 
LVL 2

Author Comment

by:DanAvni
ID: 1454228
Mirkwood,

1. Your code does not word warp text
2. I need to copy it as a picture since it formats me hebrew text in the correct RightToLeft reading order.

Any more ideas?
0
 
LVL 14

Expert Comment

by:waty
ID: 1454229
Try this to capture a control :

' #VBIDEUtils#************************************************************
' * Programmer Name  : Waty Thierry
' * Web Site         : www.geocities.com/ResearchTriangle/6311/
' * E-Mail           : waty.thierry@usa.net
' * Date             : 24/09/98
' * Time             : 13:53
' * Module Name      : Capture_Module
' * Module Filename  : Capture.bas
' **********************************************************************
' * Comments         : Screen capture code
' *
' *
' **********************************************************************

Option Explicit

' *** declares to disable PC
Public Const SPI_SCREENSAVERRUNNING = 97

Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Boolean, ByVal fuWinIni As Long) As Long

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 ' 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 Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

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

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 Type PicBmp
   Size     As Long
   nType    As Long
   hBmp     As Long
   hPal     As Long
   Reserved As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long

Public 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 Picture
   ' *** CaptureWindow
   ' *** - Captures any portion of a window
   ' ***
   ' *** hWndSrc
   ' *** - Handle to the window to be captured
   ' ***
   ' *** Client
   ' - If True CaptureWindow captures from the client area of the window
   ' *** - If False CaptureWindow captures from the entire window
   ' ***
   ' *** LeftSrc, TopSrc, WidthSrc, HeightSrc
   ' *** - Specify the portion of the window to capture
   ' *** - Dimensions need to be specified in pixels
   ' ***
   ' *** Returns
   ' - Returns a Picture object containing a bitmap of the specified
   ' *** portion of the window that was captured
   
   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) ' Raster capabilities
   HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette support
   PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of palette
   ' *** If the screen has a palette make a copy and realize it

   If HasPaletteScrn And (PaletteSizeScrn = 256) Then
      ' *** Create a copy of the system palette
      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 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 t
   '     he bitmap
   ' and palette handles. Then return the resulting picture obj
   '     ect.
   Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
   
End Function

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
   ' #VBIDEUtils#************************************************************
   ' * Programmer Name  : Waty Thierry
   ' * Web Site         : www.geocities.com/ResearchTriangle/6311/
   ' * E-Mail           : waty.thierry@usa.net
   ' * Date             : 13/10/98
   ' * Time             : 09:18
   ' * Module Name      : Capture_Module
   ' * Module Filename  : Capture.bas
   ' * Procedure Name   : CreateBitmapPicture
   ' * Parameters       :
   ' *                    ByVal hBmp As Long
   ' *                    ByVal hPal As Long
   ' **********************************************************************
   ' * Comments         : Creates a bitmap type Picture object from a bitmap
   ' *   and palette
   ' *  hBmp
   ' * - Handle to a bitmap
   ' *
   ' *  hPal
   ' * - Handle to a Palette
   ' * - Can be null if the bitmap doesn't use a palette
   ' *
   ' *  Returns
   ' * - Returns a Picture object containing the bitmap
   ' *
   ' *
   ' **********************************************************************
   
   Dim r                As Long
   Dim Pic              As PicBmp
   
   ' *** IPicture requires a reference to "Standard OLE Types"
   Dim ipic             As IPicture
   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
      .nType = 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


0
 
LVL 2

Author Comment

by:DanAvni
ID: 1454230
Almost there! Since it needs a textbox (Label does not have hwnd) I need to be able to capture it when the textbox is invisible (or get the hwnd of the label since the label is always visible and the text box is only visible when changing the text in the label).
 
0
 

Expert Comment

by:lankford
ID: 1454231
This probably isn't what you are looking for . . .

Can't you just use a textbox control instead of a label control?  You would have to change the properties so that it looks like a label control.  That way you have the handle you need to make the api call.

lankford
0
 
LVL 2

Author Comment

by:DanAvni
ID: 1454232
I am willing to use a text box if I can make it transparent so I will be able to see whats behind it. (Behind the label there is a picture and sincee a label can be transparent then i can see it but as far as i know VB only allows Opaque textboxes)
0
 
LVL 10

Expert Comment

by:caraf_g
ID: 1454233
Dan,

I hope the text in the following comment does what you want.

Copy it with Notepad and then save the file as frmPS.frm

This is VB5 but with minor mods it might work for other versions too.

Good luck (PS - wait until I've pasted the comment)
0
 
LVL 10

Expert Comment

by:caraf_g
ID: 1454234
VERSION 5.00
Begin VB.Form frmPS
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Form1"
   ClientHeight    =   6120
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6120
   ScaleWidth      =   4680
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton Command1
      Caption         =   "Command1"
      Height          =   615
      Left            =   2880
      TabIndex        =   2
      Top             =   1440
      Width           =   1575
   End
   Begin VB.PictureBox Picture1
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   2655
      Left            =   360
      ScaleHeight     =   2655
      ScaleWidth      =   3135
      TabIndex        =   1
      Top             =   2040
      Width           =   3135
   End
   Begin VB.TextBox Text1
      Height          =   1335
      Left            =   360
      TabIndex        =   0
      Text            =   "Text1"
      Top             =   600
      Width           =   1575
   End
End
Attribute VB_Name = "frmPS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 0
 
Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) 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 Declare Function GetDesktopWindow Lib _
   "user32" () As Long
 
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 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 GetWindowDC Lib "user32" _
   (ByVal hWnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _
   (ByVal hWnd As Long, ByVal hdc As Long) As Long

Private Declare Function OleCreatePictureIndirect Lib _
   "olepro32.dll" _
   (PicDesc As PicBmp, RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    IPic As IPicture) As Long


Public Function GetOLEScreenSnapshot() As Picture
'This function with thanks to VB NET!

    Dim hWndSrc As Long
    Dim hDCSrc As Long
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim WidthSrc As Long
    Dim HeightSrc As Long
   
    Dim r As Long
   
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
   
  'CaptureWindow
   WidthSrc = Screen.Width \ Screen.TwipsPerPixelX
   HeightSrc = Screen.Height \ Screen.TwipsPerPixelY
   
  'Get a handle to the desktop window and get the proper device context
   hWndSrc = GetDesktopWindow()
   hDCSrc = GetWindowDC(hWndSrc)
   
  '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)
   
  'Copy the on-screen image into the memory DC
   r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, _
              hDCSrc, 0, 0, vbSrcCopy)
   
  'Remove the new copy of the the on-screen image
   hBmp = SelectObject(hDCMemory, hBmpPrev)
   
  'Release the device context resources back to the system
   r = DeleteDC(hDCMemory)
   r = ReleaseDC(hWndSrc, hDCSrc)
   
  'Fill in OLE 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 = 0&               'Handle to palette (may be null)
    End With
   
  'Create OLE Picture object
   r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
   
  'Return the new Picture object
   Set GetOLEScreenSnapshot = IPic

End Function

Public Function GetOLEPartSnapshot(intLeft As Integer, _
                                   intTop As Integer, _
                                   intHeight As Integer, _
                                   intWidth As Integer) As Picture

    Dim hWndSrc As Long
    Dim hDCSrc As Long
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim WidthSrc As Long
    Dim HeightSrc As Long
   
    Dim r As Long
   
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
   
  'CaptureWindow
   WidthSrc = intWidth \ Screen.TwipsPerPixelX
   HeightSrc = intHeight \ Screen.TwipsPerPixelY
   
  'Get a handle to the desktop window and get the proper device context
   hWndSrc = GetDesktopWindow()
   hDCSrc = GetWindowDC(hWndSrc)
   
  '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)
   
  'Copy the on-screen image into the memory DC
   r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, _
              hDCSrc, intLeft \ Screen.TwipsPerPixelX, intTop \ Screen.TwipsPerPixelY, vbSrcCopy)
   
  'Remove the new copy of the the on-screen image
   hBmp = SelectObject(hDCMemory, hBmpPrev)
   
  'Release the device context resources back to the system
   r = DeleteDC(hDCMemory)
   r = ReleaseDC(hWndSrc, hDCSrc)
   
  'Fill in OLE 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 = 0&               'Handle to palette (may be null)
    End With
   
  'Create OLE Picture object
   r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
   
  'Return the new Picture object
   Set GetOLEPartSnapshot = IPic

End Function

Private Sub Command1_Click()

'Get exact top and left co-ordinates of text box
Dim intLeft As Integer
Dim intTop As Integer
Dim intBorderWidth As Integer

intBorderWidth = (Width - ScaleWidth) / 2

intLeft = Left + intBorderWidth + Text1.Left
intTop = Top + Height - ScaleHeight - intBorderWidth + Text1.Top

Picture1.Picture = GetOLEPartSnapshot(intLeft, intTop, Text1.Height, Text1.Width)

End Sub

0
Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

 
LVL 10

Expert Comment

by:caraf_g
ID: 1454235
PS - you have to add a reference to "Standard OLE Types" (olepro32.dll) to your project.
0
 
LVL 3

Expert Comment

by:jbil
ID: 1454236
With appologies to Dan Appleman (the get capture inclosed is from his cd "Programmers guide to the win API").
 If you are able to put the label or text box on another form (form2) and set border to none backgnd to white and just big enough to hold label or textbox. this will take snap of that form and put in in the picturebox of form1.



VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.2#0"; "COMCTL32.OCX"
Begin VB.Form Form1
   AutoRedraw      =   -1  'True
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   213
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   312
   StartUpPosition =   3  'Windows Default
   Begin ComctlLib.Toolbar Toolbar1
      Height          =   420
      Left            =   1080
      TabIndex        =   4
      Top             =   2490
      Width           =   420
      _ExtentX        =   741
      _ExtentY        =   741
      Appearance      =   1
      _Version        =   327682
      BeginProperty Buttons {0713E452-850A-101B-AFC0-4210102A8DA7}
         NumButtons      =   1
         BeginProperty Button1 {0713F354-850A-101B-AFC0-4210102A8DA7}
            Object.Tag             =   ""
            Style           =   1
         EndProperty
      EndProperty
      BorderStyle     =   1
   End
   Begin VB.CommandButton Command1
      Caption         =   "Command1"
      Height          =   375
      Left            =   4065
      TabIndex        =   3
      Top             =   1305
      Width           =   510
   End
   Begin VB.TextBox Text1
      Height          =   690
      Left            =   2625
      MultiLine       =   -1  'True
      OLEDragMode     =   1  'Automatic
      OLEDropMode     =   2  'Automatic
      TabIndex        =   1
      Text            =   "txt2pix.frx":0000
      Top             =   2220
      Width           =   1380
   End
   Begin VB.PictureBox Picture1
      AutoRedraw      =   -1  'True
      FillStyle       =   0  'Solid
      Height          =   2325
      Left            =   15
      ScaleHeight     =   2265
      ScaleWidth      =   3795
      TabIndex        =   0
      Top             =   -30
      Width           =   3855
   End
   Begin VB.Label Label1
      Caption         =   "Label1"
      Height          =   540
      Left            =   600
      TabIndex        =   2
      Top             =   2535
      Width           =   1275
      WordWrap        =   -1  'True
   End
   Begin VB.Image Image1
      Height          =   240
      Left            =   2805
      Picture         =   "txt2pix.frx":0006
      Top             =   840
      Width           =   240
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Const VK_SNAPSHOT = &H2C
Private Const WM_KEYDOWN = &H100
Private Const VK_MENU = &H12
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function OemKeyScan Lib "user32" (ByVal wOemChar As Integer) As Long
Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal _
lpszDst As String) As Long
Private Declare Function VkKeyScan Lib "user32" Alias "VkKeyScanA" (ByVal cChar As Byte) As Integer
Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, _
ByVal wMapType As Long) As Long
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2

Public Sub MyCapture(ByVal mode%)
    Dim altscan%
    Dim dl&
    Dim snapparam%
    altscan% = MapVirtualKey(VK_MENU, 0)
    Screen.MousePointer = vbHourglass
    If mode Then
        keybd_event VK_MENU, altscan, 0, 0
        ' It seems necessary to let this key get processed before
        ' taking the snapshot.
    End If
   
    ' Why does this work?  Who knows!
    If mode = 0 Then snapparam = 1 'And IsWindows95
   
    DoEvents    ' These seem necessary to make it reliable
   
    ' Take the snapshot
    keybd_event VK_SNAPSHOT, snapparam, 0, 0
   
    DoEvents
   
    Picture1.Picture = Clipboard.GetData(vbCFBitmap)
    If mode Then keybd_event VK_MENU, altscan, KEYEVENTF_KEYUP, 0
   
    Screen.MousePointer = vbDefault

End Sub


Private Sub Command1_Click()
Form2.Show
Form2.ZOrder
Form2.SetFocus
'Form2.Text1.SetFocus
MyCapture 1
Me.SetFocus
End Sub

0
 
LVL 10

Expert Comment

by:caraf_g
ID: 1454237
Dan,

Don't know what happened there but when you copy my code as is, you'll get rubbish and it won't compile.

next comment is second attempt to paste same...
0
 
LVL 10

Expert Comment

by:caraf_g
ID: 1454238
VERSION 5.00
Begin VB.Form frmPS
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   Begin VB.PictureBox Picture1
      Height          =   1335
      Left            =   960
      ScaleHeight     =   1275
      ScaleWidth      =   2235
      TabIndex        =   2
      Top             =   1680
      Width           =   2295
   End
   Begin VB.TextBox Text1
      Height          =   855
      Left            =   240
      TabIndex        =   1
      Text            =   "Text1"
      Top             =   480
      Width           =   1455
   End
   Begin VB.CommandButton Command1
      Caption         =   "Command1"
      Height          =   495
      Left            =   2760
      TabIndex        =   0
      Top             =   960
      Width           =   1335
   End
End
Attribute VB_Name = "frmPS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 0
 
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) 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 Declare Function GetDesktopWindow _
    Lib "user32" () As Long

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 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 GetWindowDC Lib "user32" _
   (ByVal hWnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _
   (ByVal hWnd As Long, ByVal hdc As Long) As Long

Private Declare Function OleCreatePictureIndirect Lib _
   "olepro32.dll" _
   (PicDesc As PicBmp, RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    IPic As IPicture) As Long


Public Function GetOLEScreenSnapshot() As Picture
'This function with thanks to VB NET!

    Dim hWndSrc As Long
    Dim hDCSrc As Long
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim WidthSrc As Long
    Dim HeightSrc As Long
   
    Dim r As Long
   
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
   
   'CaptureWindow
    WidthSrc = Screen.Width \ Screen.TwipsPerPixelX
    HeightSrc = Screen.Height \ Screen.TwipsPerPixelY
   
   'Get a handle to the desktop window and get the proper device context
    hWndSrc = GetDesktopWindow()
    hDCSrc = GetWindowDC(hWndSrc)
   
   '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)
   
   'Copy the on-screen image into the memory DC
    r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, _
               hDCSrc, 0, 0, vbSrcCopy)
   
   'Remove the new copy of the the on-screen image
    hBmp = SelectObject(hDCMemory, hBmpPrev)
   
   'Release the device context resources back to the system
    r = DeleteDC(hDCMemory)
    r = ReleaseDC(hWndSrc, hDCSrc)
   
   'Fill in OLE 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 = 0&               'Handle to palette (may be null)
    End With
   
   'Create OLE Picture object
    r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
   
   'Return the new Picture object
    Set GetOLEScreenSnapshot = IPic

End Function

Public Function GetOLEPartSnapshot(intLeft As Integer, _
                                   intTop As Integer, _
                                   intHeight As Integer, _
                                   intWidth As Integer) As Picture

    Dim hWndSrc As Long
    Dim hDCSrc As Long
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim WidthSrc As Long
    Dim HeightSrc As Long
   
    Dim r As Long
   
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
   
   'CaptureWindow
    WidthSrc = intWidth \ Screen.TwipsPerPixelX
    HeightSrc = intHeight \ Screen.TwipsPerPixelY
   
   'Get a handle to the desktop window and get the proper device context
    hWndSrc = GetDesktopWindow()
    hDCSrc = GetWindowDC(hWndSrc)
   
   '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)
   
   'Copy the on-screen image into the memory DC
    r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, _
               hDCSrc, intLeft \ Screen.TwipsPerPixelX, intTop \ Screen.TwipsPerPixelY, vbSrcCopy)
   
   'Remove the new copy of the the on-screen image
    hBmp = SelectObject(hDCMemory, hBmpPrev)
   
   'Release the device context resources back to the system
    r = DeleteDC(hDCMemory)
    r = ReleaseDC(hWndSrc, hDCSrc)
   
   'Fill in OLE 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 = 0&               'Handle to palette (may be null)
    End With
   
   'Create OLE Picture object
    r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
   
   'Return the new Picture object
    Set GetOLEPartSnapshot = IPic

End Function

Private Sub Command1_Click()

'Get exact top and left co-ordinates of text box
Dim intLeft As Integer
Dim intTop As Integer
Dim intBorderWidth As Integer

intBorderWidth = (Width - ScaleWidth) / 2

intLeft = Left + intBorderWidth + Text1.Left
intTop = Top + Height - ScaleHeight - intBorderWidth + Text1.Top

Picture1.Picture = GetOLEPartSnapshot(intLeft, intTop, Text1.Height, Text1.Width)

End Sub

0
 
LVL 10

Expert Comment

by:caraf_g
ID: 1454239
Ok.... here goes.

When I copy the above code into Notepad, each blank in the above code is put into the Notepad file as a character 160 which looks blank but isn't.

After you've copied into Notepad, run a Replace and replace all these characters with real blanks.

After that you can save and you should be OK

Don't know why this happens...
0
 
LVL 2

Author Comment

by:DanAvni
ID: 1454240
Since in my application there is a picturee behind the text i need to make the textbox transparent (If I use a label then I can make it transparent but I can't copy it as a picture, and then the textbox is not visible and it is not copied as a picturee.) Any Ideas?
0
 
LVL 3

Expert Comment

by:jbil
ID: 1454241
Dan
  Are you saying you want to copy just the label as a picture, or the lable and the section of the picture behind it as a picture?
0
 
LVL 2

Author Comment

by:DanAvni
ID: 1454242
Found a solution. Thanks...
0
 
LVL 10

Expert Comment

by:caraf_g
ID: 1454243
I'm interested! What did you do in the end?
0
 
LVL 2

Author Comment

by:DanAvni
ID: 1454244
I have a image control which supports transparent bitmaps instead of a label and when the user clicks it a textbox appears. when editing is finished i copy the textbox image and put it in the image control wich a transparent color of white(like the back of the textbox) that way it all works.
0
 
LVL 10

Expert Comment

by:caraf_g
ID: 1454245
Neat! Thanks..
0
 
LVL 2

Expert Comment

by:polygon
ID: 1454246
Another solution would be just converting the left, top, he., width properies of you control (textbox or lable, doesn't matter) and then use bitblt to copy just the part of you form that holds your control.
0
 
LVL 1

Accepted Solution

by:
Renato102098 earned 300 total points
ID: 1454247
If you put the textbox outside the form por example:
text1.left = -1000
text1.top = - 1000
text1.visible = true
you can't view, but it is visible for Visual Basic

You wrote
Since in my application there is a picturee behind the text i need to make the textbox transparent (If I use a label then I can make it transparent but I can't copy it as a picture, and then the textbox is not visible and it is not copied as a picturee.) Any Ideas?
 

0

Featured Post

What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

Join & Write a Comment

Suggested Solutions

Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
Background What I'm presenting in this article is the result of 2 conditions in my work area: We have a SQL Server production environment but no development or test environment; andWe have an MS Access front end using tables in SQL Server but we a…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now