vb下双缓冲模式中缩放的实现

Question

我在vb中作了一个双缓冲的图形显示程序，基本可用但无法用ScaleViewportExtEx实现图形缩放
不知是否内存设备场景部支持该函数？
源程序包括一个窗体上面有两个按钮 zoomin,zoomout,一个模块见下个贴子
Option Explicit
Dim m_dc As Long
Dim mScale As Single
Dim mWidth As Long
Dim mHeight As Long
Dim m_lnghwnd As Long
Dim m_lngdc As Long
Dim sa(60) As Single
Dim scaleIndex As Integer
Dim pNewbmp As Long
Dim pOldBmp As Long
Dim SrcBitmapWidth As LongDim SrcBitmapHeight As Long
Private Function Frefresh() As Integer
Dim iLeft As Integer
Dim iTop As Integer
Dim iBitmapWidth As Integer
Dim iBitmapHeight As IntegerDim rect1 As RECT  'rect1：矩形类rect的实例
Dim a As Long      'a：判断（返回指定窗口客户区矩形的大小）是否成功
a = GetClientRect(Me.hwnd, rect1)
If a <> 0 Then
    BitBlt m_lngdc, 0, 0, rect1.Right, rect1.Bottom, m_dc, 0, 0, vbSrcCopy
'    StretchBlt m_lngdc, rect1.Left, rect1.Top, rect1.Right, rect1.Bottom, m_dc, 0, 0, rect1.Bottom, rect1.Bottom, vbSrcCopy
End IfEnd Function
Private Sub Form_Load()
mWidth = 5000
mHeight = 5000
'Me.Height = mHeight
'Me.Width = mWidth
mScale = 1.2
m_lnghwnd = Me.hwnd
m_lngdc = GetDC(m_lnghwnd)
m_dc = CreateCompatibleDC(m_lngdc) '(m_lngDC)
sa(0) = 1
sa(1) = 1.2
sa(2) = 1.4
sa(3) = 1.6
sa(4) = 1.8
sa(5) = 1.9
sa(6) = 2.1
sa(7) = 2.3
sa(8) = 2.5
sa(9) = 2.8
sa(10) = 3#
sa(11) = 3.5
sa(12) = 3.6
scaleIndex = 0
ZoomIN.Move 0, 0
ZoomOut.Move ZoomOut.Width, 0
pNewbmp = CreateCompatibleBitmap(m_lngdc, 5000, 5000)
If pNewbmp = 0 Then
    pNewbmp = CreateCompatibleBitmap(m_dc, 5000, 5000) '如果创建彩色失败尝试黑白位图
End If
Dim rect1 As RECT  'rect1：矩形类rect的实例
Dim a As Long      'a：判断（返回指定窗口客户区矩形的大小）是否成功
a = GetClientRect(Me.hwnd, rect1)
SrcBitmapWidth = rect1.Right
SrcBitmapHeight = rect1.Bottom
pOldBmp = SelectObject(m_dc, pNewbmp)
Dim p As SIZE
Dim s
s = SetMapMode(m_dc, 8)
Dim ret1 As Long
Dim ret2 As Long
ret1 = SetWindowExtEx(m_dc, 500, 500, p)
ret2 = SetViewportExtEx(m_dc, CLng(500 * mScale), CLng(500 * mScale), p)
End SubPublic Function GenerateBitmap()
Dim SelectReturn As Long
Dim deleteReturn As Long
Dim Fillreturn As Long
Dim brushcolor As Long
Dim BrushRect As RECT
'**********************************************
Dim pMap As Long
mScale = sa(scaleIndex)
Me.Height = mHeight * mScale
Me.Width = mWidth * mScale
Dim rect1 As RECT  'rect1：矩形类rect的实例
Dim a As Long      'a：判断（返回指定窗口客户区矩形的大小）是否成功
a = GetClientRect(Me.hwnd, rect1)
Dim p As SIZE
Dim s As Long
s = SetMapMode(m_dc, 8)
ScaleViewportExtEx m_dc, mScale * 9, mScale * 3, 1, 1, p
'用化刷讲背景填写白色
Dim m_brushdc As Long
Dim pR As RECT
pR.Left = 30
pR.Top = 30
pR.Bottom = rect1.Bottom
BrushRect.Left = 0
BrushRect.Top = 0
BrushRect.Right = mWidth
BrushRect.Bottom = mHeight
brushcolor = GetBkColor(m_dc)
m_brushdc = CreateSolidBrush(brushcolor)
SelectReturn = SelectObject(m_dc, m_brushdc)
Fillreturn = FillRect(m_dc, BrushRect, m_brushdc)
SelectReturn = SelectObject(m_dc, SelectReturn)deleteReturn = DeleteObject(m_brushdc)
DeleteObject SelectReturn
Ellipse m_dc, 0, 0, 300, 300DrawText m_dc, "中华人民共和国", 14, rect1, 1
Frefresh
End FunctionPrivate Sub Form_Unload(Cancel As Integer)pOldBmp = SelectObject(m_dc, pOldBmp)
DeleteObject pOldBmp
DeleteObject m_lngdc
DeleteObject m_dc
End SubPrivate Sub ZoomIN_Click()
If scaleIndex > 0 Then
scaleIndex = scaleIndex - 1
End If
GenerateBitmap
End SubPrivate Sub ZoomOut_Click()
If scaleIndex < UBound(sa) Then
    scaleIndex = scaleIndex + 1
End If
GenerateBitmap
End Sub

Answer 1

上个源程序中模块里的源代码，用到的api的声明，ScaleViewportExtEX俄实现缩放时等比例缩放不成功，不等比例情况出现更怪异
Option Explicit
Public Declare Function SetWindowExtEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpSize As SIZE) As Long
Public Declare Function SetViewportExtEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpSize As SIZE) As Long
'api declare******************************************
'给窗体发送消息
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Const SW_MAX = 10
Public Const SW_HIDE = 0
Public Const SW_MINIMIZE = 6
Public Const SW_NORMAL = 1
Public Const GW_OWNER = 4
Public Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
Public Const MM_ANISOTROPIC = 8
'关于画图设备的API函数
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleDC 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
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'划线时调用的API函数
Public Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Public Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Const LOGPIXELSX = 88        '  Logical pixels/inch in X
Public Const LOGPIXELSY = 90        '  Logical pixels/inch in Y
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long'输出汉字时调用的API函数
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As LongPublic Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
'填充矩形颜色时调用的API函数
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long'位图操作方面的API函数
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As LongPublic Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function ScaleViewportExtEx Lib "gdi32" (ByVal hdc As Long, ByVal nXnum As Long, ByVal nXdenom As Long, ByVal nYnum As Long, ByVal nYdenom As Long, lpSize As SIZE) As Long
'type declare*******************************************
'API中的矩形结构——新的数据类型
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type''剪切板对象
'Public m_ClipBoard As CClipBoard'API中的点结构——新的数据类型
Public Type POINTAPI
    X As Long
    Y As Long
End Type'API中的字体结构——新的数据类型
Public Type LOGFONT
     lfHeight As Long
     lfWidth As Long
     lfEscapement As Long
     lfOrientation As Long
     lfWeight As Long
     lfItalic As Byte
     lfUnderline As Byte
     lfStrikeOut As Byte
     lfCharSet As Byte
     lfOutPrecision As Byte
     lfClipPrecision As Byte
     lfQuality As Byte
     lfPitchAndFamily As Byte
     lfFaceName As String * 50
End Type'API中的字体尺寸结构--新的数据类型
Public Type SIZE
    cx As Long
    cy As Long
End TypePublic Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 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 Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type
'Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function CreateDCBynum& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long)
'Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long