How to copy 3D surface plot to the Clipboard

[rfgrove]

Does anyone have VB6 code to copy a 3D surface plot to the Windows clipboard? I am using the sample program btest2 modified for my application. The following code produces the 3D plot

PlotViewAz = Val(Text2.text)
PlotViewEl = Val(Text3.text)
ZplotScaleFactor = Val(Text1.text)
HasMetrics = 0

d.version = DPLOT_DDE_VERSION
d.hwnd = Me.hwnd
d.DataFormat = DATA_3D
d.MaxCurves = Nx - 1
d.MaxPoints = Ny - 1
d.NumCurves = 1
d.ScaleCode = SCALE_LINEARX_LINEARY
d.Title1 = "SurfacePlot"
d.Title2 = ""
d.Title3 = ""
d.XAxis = "Range"
d.YAxis = "Deflection"

cmds = "[Contour3D(1)][ContourGrid(1)][ContourAxes(1)]"
cmds = cmds & "[ContourView(" & Str(PlotViewAz) & "," & Str(PlotViewEl) & ")]"
cmds = cmds & "[ContourLegend(0)]"
cmds = cmds + "[ContourLevels(20," & Str(zMin) & "," & Str(zMax) & ")]"
cmds = cmds & "[ContourScales(1,1," & Str(ZplotScaleFactor) & ")]"
cmds = cmds & "[FontPoints(1,8)][FontPoints(2,12)][FontPoints(3,12)]"
cmds = cmds & "[FontPoints(4,10)][FontPoints(5,10)][FontPoints(6,8)]"
cmds = cmds & "[ZAxisLabel(""frequency"")]"

ret = GetClientRect(Picture1.hwnd, rcPic)
If (hBitmap <> 0) Then
ret = DeleteObject(hBitmap)
hBitmap = 0
End If
If DocNum <> 0 Then
ret = DPlot_Command(DocNum, "[FileClose()]")
End If
DocNum = DPlot_Plot(d, extents(0), Z(0), cmds)
If (DocNum > 0) Then
hBitmap = DPlot_GetBitmap(DocNum, rcPic.Right - rcPic.Left, rcPic.Bottom - rcPic.Top)
End If
Call Picture1_Paint

Private Sub Picture1_Paint()
Dim bm As BITMAP
Dim hbmpOld As Long
Dim hdc As Long
Dim hdcMem As Long
Dim ret As Long

If hBitmap <> 0 Then
hdc = GetDC(Picture1.hwnd)
hdcMem = CreateCompatibleDC(hdc)
If (hdcMem <> 0) Then
hbmpOld = SelectObject(hdcMem, hBitmap)
ret = GetObject(hBitmap, Len(bm), bm)

ret = SetBkMode(hdc, NEWTRANSPARENT)
ret = SetBkColor(hdc, RGB(255, 255, 255))

ret = BitBlt(hdc, rcPic.Left, rcPic.Top, bm.bmWidth, bm.bmHeight, hdcMem, 0, 0, SRCCOPY)
ret = SelectObject(hdcMem, hbmpOld)
ret = DeleteDC(hdcMem)
End If
ret = ReleaseDC(Picture1.hwnd, hdc)
End If
End Sub

[DPlotAdmin]

Does your copy of the btest2 demo not include a "Copy" button?

Code: Select all

Private Sub Command4_Click()
'
'   Copy bitmap to the Clipboard
'
    Dim hbmpCopy As Long
    Dim ret As Long
    
    If (hBitmap <> 0) Then
        ret = OpenClipboard(Me.hwnd)
        ret = EmptyClipboard()
        hbmpCopy = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        ret = SetClipboardData(CF_BITMAP, hbmpCopy)
        ret = CloseClipboard()
    Else
        Beep
    End If

End Sub

Extracted from global.vb:

Code: Select all

Global Const CF_BITMAP = 2

Global Const IMAGE_BITMAP = 0

Global Const LR_COPYRETURNORG = &H4

Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long