How to copy 3D surface plot to the Clipboard
Posted: Mon Jan 15, 2007 10:38 am
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
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