?
Solved

Saving a picture with labels

Posted on 2003-03-25
16
Medium Priority
?
285 Views
Last Modified: 2010-05-01
I need to be able to save a picture with labels which are predrawn with captions on the form.  When I use the SavePicture command everything else within picture1 is saved but not the labels.  How can I get them to be saved in the current position?

Code for saving is as follows

Private Sub Command4_Click()
Dim filename As String
CommonDialog1.DialogTitle = "Save Picture"
    CommonDialog1.Filter = "BMP (*.BMP)|*.bmp"
    CommonDialog1.FilterIndex = 2
    CommonDialog1.ShowSave
    '
    filename = CommonDialog1.filename
    SavePicture Picture1.Image, filename
End Sub

Many thanks in advance

Iain
0
Comment
Question by:ICowan
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 6
  • 4
  • 4
  • +2
16 Comments
 
LVL 28

Expert Comment

by:vinnyd79
ID: 8203381
have you tried printing the form:

Private Sub Command1_Click()
Me.PrintForm
End Sub
0
 
LVL 3

Expert Comment

by:Jonyv
ID: 8203604
The labels are not a part of the picture and won't be saved by 'SavePicture'. What you need to do is to take a "snapshot" of the picture and save that.
Some code to help you:
Paste the code below into a BAS module and change your save code to:
SavePicture hDCToPicture(Picture1.hDC, 0, 0, Picture1.Width / Screen.TwipsPerPixelX, Picture1.Height / Screen.TwipsPerPixelY), filename
For this to work, the whole picture must be visible in the picturebox since the function actually saves what's visible on the screen.

*Begin code*

Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Public Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Public Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Public Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Public Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Public 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
Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long


Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38

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


Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

    'Fill GUID info
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    'Fill picture info
    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 the picture
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

    'Return the new picture
    Set CreateBitmapPicture = IPic
End Function

Public Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
   
    Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
    Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

    'Create a compatible device context
    hDCMemory = CreateCompatibleDC(hDCSrc)
    'Create a compatible bitmap
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    'Select the compatible bitmap into our compatible device context
    hBmpPrev = SelectObject(hDCMemory, hBmp)

    'Raster capabilities?
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
    'Does our picture use a palette?
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
    'What's the size of that palette?
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'Set the palette version
        LogPal.palVersion = &H300
        'Number of palette entries
        LogPal.palNumEntries = 256
        'Retrieve the system palette entries
        R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        'Create the palette
        hPal = CreatePalette(LogPal)
        'Select the palette
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        'Realize the palette
        R = RealizePalette(hDCMemory)
    End If

    'Copy the source image to our compatible device context
    R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

    'Restore the old bitmap
    hBmp = SelectObject(hDCMemory, hBmpPrev)

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'Select the palette
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If

    'Delete our memory DC
    R = DeleteDC(hDCMemory)

    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function

*End code*
0
 

Author Comment

by:ICowan
ID: 8203753
This doesn't seem to work either Jonyv, all that happens is the same picture is printed out with a border on two sides with strange colours in it.

Any other comments?

Iain
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 16

Expert Comment

by:Richie_Simonetti
ID: 8203764
hearing...
0
 
LVL 3

Expert Comment

by:Jonyv
ID: 8204150
Hmm, that's strange, it worked when I tested it, but perhaps i misunderstod what you're trying to do. This is what I did to test the code, tell me if this is is different from what you want.

*Started a new VB project and added a picture box and a commandbutton
*Added a module with all the code above
*Loaded a picture in the picturebox
*Put a label with some text inside the picturebox on top of the picture
*Added this code to the button:
SavePicture hDCToPicture(Picture1.hDC, 0, 0, Picture1.Width / Screen.TwipsPerPixelX, Picture1.Height / Screen.TwipsPerPixelY), "c:\test.bmp"

That Should work, but again perhaps this is not what you are trying to do.
0
 
LVL 16

Expert Comment

by:Richie_Simonetti
ID: 8204169
if it doesn't works, try this little modification:

Set all scalemode properties to 3 (vbpixel)

Private Sub Form_Click()
Dim pic As StdPicture
    'KPD-Team 1999
    'URL: http://www.allapi.net/
    'E-Mail: KPDTeam@Allapi.net
    'Create a picture object from the screen
    Set pic = hDCToPicture(Picture1.hdc, 0, 0, Picture1.Width, Picture1.Height)
    SavePicture pic, "c:\withlabels.bmp"
End Sub
0
 
LVL 16

Expert Comment

by:Richie_Simonetti
ID: 8204185
Also, set borderstyle's picturebox to none and autoredraw to false.
0
 
LVL 5

Expert Comment

by:JMoon5FTM
ID: 8204827
Are the labels children of the picture box?  If not, make them children and try saving it again.  Labels are windowless controls and so should draw on the parent.
0
 

Author Comment

by:ICowan
ID: 8209156
*What I have done is to create the form, draw a picture box on it

*Then put the labels in the correct position and give them captions

*Drawn a circle and bisected it in to sectors (by code)

*Coloured each sector according to value within an array

*I now need to save the picture.

*If I use me.printform, the form prints out with the labels, however, I need to save the picture to a bmp and the whole thing with the module code still doesn't work.

Iain
0
 
LVL 3

Expert Comment

by:Jonyv
ID: 8209298
Thats really strange, because it works fine when I try to do the same (except for the part about the borders being included, but that can be fixed easily).

Could you post your code, or send it to me so I could have a look at it?
0
 

Author Comment

by:ICowan
ID: 8209377
Private Sub Form_Load()
Picture1.AutoSize = True          
Picture1.AutoRedraw = True
Picture1.ScaleMode = vbPixels
Picture1.FillStyle = vbFSTransparent
'Draw Circle
Picture1.Circle (348.2, 332.5), 313.3
Picture1.Line (348.2, 19.2)-(348.2, 646.8)
Picture1.Line (34.9, 332.5)-(661.8, 332.5)
Picture1.Line (126.66, 110.96)-(571.5, 555.53)
Picture1.Line (569.7, 110.96)-(125, 555.53)
'
'Draw boxes
For i = 120 To 344 Step 32
Picture1.Line (i, 656)-(i, 681)
Picture1.Line (i, 656)-(i + 25, 656)
Picture1.Line (i, 681)-(i + 25, 681)
Picture1.Line (i + 25, 656)-(i + 25, 681)
Next
'labels on the picture

Picture1.FillStyle = vbSolid
For i = 125 To 349 Step 32
    'Colours for Scale
    If i = 125 Then
        Picture1.FillColor = &H1B00B3
        ExtFloodFill Picture1.hDC, i, 660, 0, floodfillborder
    ElseIf i = 157 Then
        Picture1.FillColor = &H2000D2
        ExtFloodFill Picture1.hDC, i, 660, 0, floodfillborder
    ElseIf i = 189 Then
        Picture1.FillColor = &H2400F2
        ExtFloodFill Picture1.hDC, i, 660, 0, floodfillborder
    ElseIf i = 221 Then
        Picture1.FillColor = &H3815FF
        ExtFloodFill Picture1.hDC, i, 660, 0, floodfillborder
    ElseIf i = 253 Then
        Picture1.FillColor = &H5F42FF
        ExtFloodFill Picture1.hDC, i, 660, 0, floodfillborder
    ElseIf i = 285 Then
        Picture1.FillColor = &H7D66FF
        ExtFloodFill Picture1.hDC, i, 660, 0, floodfillborder
    ElseIf i = 317 Then
        Picture1.FillColor = &HB4A6FF
        ExtFloodFill Picture1.hDC, i, 660, 0, floodfillborder
    ElseIf i = 349 Then
        Picture1.FillColor = &HE4DFFF
        ExtFloodFill Picture1.hDC, i, 660, 0, floodfillborder
    End If
Next
'Sectors then coloured in according to array but won't go in to that program part
End sub

Private Sub Command2_Click()
Dim C_Filesave As String
    CommonDialog1.DialogTitle = "Save Picture File"
    CommonDialog1.Filter = "BMP (*.BMP)|*.bmp"
    CommonDialog1.FilterIndex = 2
    CommonDialog1.ShowSave
   
    C_Filesave = CommonDialog1.FileName
    SavePicture hDCToPicture(Picture1.hDC, 0, 0, Picture1.Width / Screen.TwipsPerPixelX, Picture1.Height / Screen.TwipsPerPixelY), C_Filesave
End Sub

have also tried putting picture width and height in pixels as numbers, this still does not work.

Thanks for your help.

Iain
0
 
LVL 3

Accepted Solution

by:
Jonyv earned 200 total points
ID: 8209609
Ok, the problem here seems to be: Picture1.AutoRedraw = True

If you set AutoRedraw to false the labels get saved, but then your graphics doesn't work...

I will have a look att this and try to find a solution.
0
 

Author Comment

by:ICowan
ID: 8209692
The autoredraw was indeed the problem, and you needed the module part as well.

If you set autoredraw to true in the form load where you draw the circle etc, then it shows on the screen.  On the button to save the picture, autoredraw must be reset to false, the whole picture is then saved.

Many thanks all, especially JonyV.

Iain
0
 
LVL 3

Expert Comment

by:Jonyv
ID: 8209752
Ok, a simple fix is to set the AutoRedraw property to False just before calling SavePicture and then resetting it to True afterwards. This will work as long as no other windows are overlapping your picture while it's being saved.

To avoid that the borders are being included, you can use this code:
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33

Dim BorderHeight as Long
Dim BorderWidth as Long

BorderHeight = GetSystemMetrics(SM_CYFRAME)
BorderWidth = GetSystemMetrics(SM_CXFRAME)

Just subtract these values from the width and height when saving the picture.

Good luck!
0
 
LVL 3

Expert Comment

by:Jonyv
ID: 8209756
Looks like a was a little slow there  :-)
0
 
LVL 16

Expert Comment

by:Richie_Simonetti
ID: 8209785
Well, after all this was a thread of two people only.
;)
0

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
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…
Suggested Courses
Course of the Month13 days, 16 hours left to enroll

801 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