Problem in exporting picturebox with shape to a bmp (*Resolved*)

[Elysees]

I have a problem here. I have a picturebox with several shape on it, and a label. I want to save picturebox to a bitmap just as it is.

I used the following codes but what I got is an empty picture without anything on it. Anyone has idea what I missed?


-------------------------------------------------------

Private Sub Form_Load()


Dim intIndx As Integer

Picture1.AutoRedraw = True

'Load shapes
shpBox.BorderColor = RGB(255, 255, 255)
shpBox.shape = vbShapeOval
shpBox.FillColor = RGB(0, 0, 0)
shpBox.FillStyle = vbFSSolid
shpBox.Width = 1500
shpBox.Height = 500

Set shpBox.Container = Picture1

For intIndx = 0 To 3
shpGreen(intIndx).FillColor = RGB(0 + 50 * intIndx, 255, 0 + 50 * intIndx)
shpGreen(intIndx).FillStyle = vbFSSolid
' shpGreen(intIndx).FillStyle = 2 + intIndx
Next intIndx


For intIndx = 0 To 3
shpRed(intIndx).FillColor = RGB(255, 0 + 50 * intIndx, 0 + 50 * intIndx)
shpRed(intIndx).FillStyle = vbFSSolid
' shpRed(intIndx).FillStyle = 2 + intIndx
Next intIndx

For intIndx = 0 To 3
shpBlue(intIndx).FillColor = RGB(0 + 50 * intIndx, 0 + 50 * intIndx, 255)
shpBlue(intIndx).FillStyle = vbFSSolid
' shpBlue(intIndx).FillStyle = 2 + intIndx
Next intIndx

Label1.Caption = "This is a test image"


End Sub


Private Sub cmdExport_Click()

SavePicture Picture1.Image, App.Path & "\Accom_data\test1.bmp"
End Sub


Thank you in advance

[chemicalNova]

Set the autoredraw property to True then refresh it.

Private Sub cmdExport_Click()
Picture1.AutoRedraw = True
Picture1.Refresh
SavePicture Picture1.Image, App.Path & "\Accom_data\test1.bmp"
End Sub

Phreak

[Elysees]

I have tried the "AutoRedraw " but it did not work.

I searched over the VBforum and found BitBlt is a solution for this:

-------------------------------------------------------------------------

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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetDC 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 Const SRCCOPY = &HCC0020

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


Option Explicit

Private Sub cmdExport_Click()
PrintPictureBox Me.Picture1
SavePicture Picture1.Image, App.Path & "\Accom_data\test1.bmp"
End Sub

Private Sub Form_Load()

Dim intIndx As Integer

Picture1.AutoRedraw = True

'Load shapes
shpBox.BorderColor = RGB(255, 255, 255)
shpBox.shape = vbShapeOval
shpBox.FillColor = RGB(0, 0, 0)
shpBox.FillStyle = vbFSSolid
shpBox.Width = 1500
shpBox.Height = 500

Set shpBox.Container = Picture1

For intIndx = 0 To 3
shpGreen(intIndx).FillColor = RGB(0 + 50 * intIndx, 255, 0 + 50 * intIndx)
shpGreen(intIndx).FillStyle = vbFSSolid
' shpGreen(intIndx).FillStyle = 2 + intIndx
Next intIndx


For intIndx = 0 To 3
shpRed(intIndx).FillColor = RGB(255, 0 + 50 * intIndx, 0 + 50 * intIndx)
shpRed(intIndx).FillStyle = vbFSSolid
' shpRed(intIndx).FillStyle = 2 + intIndx
Next intIndx

For intIndx = 0 To 3
shpYellow(intIndx).FillColor = RGB(0 + 50 * intIndx, 0 + 50 * intIndx, 255)
shpYellow(intIndx).FillStyle = vbFSSolid
' shpYellow(intIndx).FillStyle = 2 + intIndx
Next intIndx

Label1.Caption = "This is a test image"


End Sub


'Copied from vbforum.com
'http://www.vbforums.com/showthread.php?threadid=245989&highlight=picturebox+with+shape

Public Sub PrintPictureBox(ByRef oBox As PictureBox, Optional ByVal x As Single = 0, Optional ByVal y As Single = 0)
Dim tRECT As RECT, tCLIENT As RECT
Dim lDC As Long, lX As Long, lY As Long
Dim eMode As ScaleModeConstants
Dim bRedraw As Boolean

Call GetWindowRect(oBox.hwnd, tRECT)
Call GetClientRect(oBox.hwnd, tCLIENT)

lX = ((tRECT.Right - tRECT.Left) - (tCLIENT.Right - tCLIENT.Left)) / 2
lY = ((tRECT.Bottom - tRECT.Top) - (tCLIENT.Bottom - tCLIENT.Top)) / 2

With oBox

eMode = .ScaleMode
bRedraw = .AutoRedraw

.ScaleMode = vbPixels
.AutoRedraw = True

lDC = GetDC(0)

BitBlt .hdc, 0, 0, .ScaleWidth, .ScaleHeight, lDC, tRECT.Left + lX, tRECT.Top + lY, SRCCOPY

Call ReleaseDC(0, lDC)

.Picture = .Image

' Printer.PaintPicture .Picture, x, y
' Printer.EndDoc

.AutoRedraw = False
.Cls

.AutoRedraw = bRedraw
.ScaleMode = eMode

End With
End Sub