What is wrong with mdc doing setmapmode
Amrit
Please help me. this is going to big headache for me.
i need to display more than one drawing on the Form . so i create mdc with
setmapmode MM_ANISOTROPIC. coz' i want +y coordinate up and - is down.
by default window give +Y is Down. the DPTOLP is work. but some thing wrong
with bitblt.
and one more rectangle drawn by inside white. why it come.
i don't know where and what is wrong.
please help some one.
here is comple code which i try.
'=========================== Bas File===================
Option Explicit
Public Type POINTAPI
X As Long
Y As Long
End Type
Public Type RECTAPI
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type SizeAPI
cx As Long
cy As Long
End Type
Public Type DcStruct
hWnd As Long
pDc As Long ' dc from hwnd
mDC As Long ' memory DC
mBmp As Long ' memory BMP
oBmp As Long ' old bmp to restore
DcRc As RECTAPI 'DC location and size to display in form
ViewRc As RECTAPI ' logical are of dc ' Init 0,200,0,200
ViewExt As SizeAPI ' logical Viewport size refer by ViewRc
ViewOrg As POINTAPI ' logical Origin
WinExt As SizeAPI ' window size refer by DcRc
WinOrg As POINTAPI ' window origin
mMode As Long
m_Zoom As Long ' ViewRc change by m_zoom value
Index As Long
End Type
'' API List
Public Declare Function SetMapMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal
nMapMode As Long) As Long
Public Declare Function SetWindowOrgEx Lib "gdi32.dll" (ByVal hdc As Long,
ByVal nX As Long, ByVal ny As Long, ByRef lpPoint As Any) As Long
Public Declare Function SetViewportOrgEx Lib "gdi32.dll" (ByVal hdc As Long,
ByVal nX As Long, ByVal ny As Long, ByRef lpPoint As Any) As Long
Public Declare Function SetWindowExtEx Lib "gdi32.dll" (ByVal hdc As Long,
ByVal nX As Long, ByVal ny As Long, ByRef lpSize As Any) As Long
Public Declare Function SetViewportExtEx Lib "gdi32.dll" (ByVal hdc As Long,
ByVal nX As Long, ByVal ny As Long, ByRef lpSize As Any) As Long
Public Declare Function GetClientRect Lib "user32.dll" (ByVal hWnd As Long,
ByRef lpRect As RECTAPI) As Long
Public Declare Function DPtoLP Lib "gdi32.dll" (ByVal hdc As Long, ByRef
lpPoint As Any, ByVal nCount As Long) As Long
Public Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long)
As Long
Public Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As
Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As
Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As
Long) As Long
Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Public Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long,
ByVal hdc As Long) As Long
Public Declare Function BitBlt Lib "gdi32.dll" (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 LPtoDP Lib "gdi32.dll" (ByRef hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long) As Long
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
Public Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As
Long) As Long
Public Declare Function InvalidateRect Lib "user32.dll" (ByVal hWnd As Long,
ByRef lpRect As RECTAPI, ByVal bErase As Long) As Long
Public Declare Function SetRect Lib "user32.dll" (ByRef lpRect As RECTAPI,
ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 CreatePen Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
As Long
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
RECTAPI, ByVal hBrush As Long) As Long
Public Declare Function Rectangle 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 MM_ANISOTROPIC As Long = &H8
Public Const SRCCOPY = &HCC0020
Public Const NULL_BRUSH = 5
Public Dcs() As DcStruct ' collection for DC
Public CurDC As DcStruct ' Current dc for Use
Public TmpDC As DcStruct ' Temporary DC for Make window Happy
Public MouseDownPt As POINTAPI ' defaule window device point
Public MouseUpPt As POINTAPI ' defaule window device point
Public ClickPt As POINTAPI ' logical Point convert by DPTOLP
Public MovePt As POINTAPI ' logical Point
Public Function InitFirst()
ReDim Dcs(0) As DcStruct
End Function
Public Function AddDc(hWnd As Long, Rc As RECTAPI) As DcStruct
Dcs(CurDC.Index) = CurDC
Dim i As Long
i = UBound(Dcs()) + 1
ReDim Preserve Dcs(i) As DcStruct
With AddDc
.hWnd = hWnd
.DcRc = Rc
.m_Zoom = 10
.Index = i
.mMode = MM_ANISOTROPIC
.WinExt.cx = .DcRc.Right - .DcRc.Left
.WinExt.cy = .DcRc.Bottom - .DcRc.Top
.WinOrg.X = (.DcRc.Left + .DcRc.Right) / 2
.WinOrg.Y = (.DcRc.Top + .DcRc.Bottom) / 2
Call SetRect(.ViewRc, .DcRc.Left - .m_Zoom, .DcRc.Top - .m_Zoom,
.DcRc.Right + .m_Zoom, .DcRc.Bottom + .m_Zoom)
.ViewExt.cx = .ViewRc.Right - .ViewRc.Left
.ViewExt.cy = .ViewRc.Bottom - .ViewRc.Top
.ViewOrg.X = (.ViewRc.Left + .ViewRc.Right) / 2
.ViewOrg.Y = (.ViewRc.Top + .ViewRc.Bottom) / 2
End With
Dcs(i) = AddDc
' AddDc = Dcs(i)
End Function
Public Property Let Zoom(mz As Long)
With CurDC
.m_Zoom = .m_Zoom + mz
.WinExt.cx = .DcRc.Right - .DcRc.Left
.WinExt.cy = -(.DcRc.Bottom - .DcRc.Top)
.WinOrg.X = (.DcRc.Left + .DcRc.Right) / 2
.WinOrg.Y = (.DcRc.Top + .DcRc.Bottom) / 2
Call SetRect(.ViewRc, .DcRc.Left - .m_Zoom, .DcRc.Top - .m_Zoom,
.DcRc.Right + .m_Zoom, .DcRc.Bottom + .m_Zoom)
.ViewExt.cx = .ViewRc.Right - .ViewRc.Left
.ViewExt.cy = (.ViewRc.Bottom - .ViewRc.Top)
.ViewOrg.X = (.ViewRc.Left + .ViewRc.Right) / 2
.ViewOrg.Y = (.ViewRc.Top + .ViewRc.Bottom) / 2
End With
End Property
Public Function SetDC() As DcStruct
With CurDC
TmpDC.mMode = SetMapMode(.mDC, .mMode)
'
Call SetWindowExtEx(.mDC, .WinExt.cx, .WinExt.cy, TmpDC.ViewExt)
Call SetWindowOrgEx(.mDC, .WinOrg.X, .WinOrg.Y, TmpDC.WinOrg)
Call SetViewportOrgEx(.mDC, .ViewOrg.X, .ViewOrg.Y, TmpDC.ViewOrg)
Call SetViewportExtEx(.mDC, .ViewExt.cx, .ViewExt.cy, TmpDC.ViewExt)
' just try do. but this is also wrong
' Call SetWindowExtEx(.mDC, .ViewExt.cx, .ViewExt.cy, TmpDC.ViewExt)
' Call SetWindowOrgEx(.mDC, .ViewOrg.X, .ViewOrg.Y, TmpDC.WinOrg)
'
' Call SetViewportExtEx(.mDC, .WinExt.cx, .WinExt.cy, TmpDC.ViewExt)
' Call SetViewportOrgEx(.mDC, .WinOrg.X, .WinOrg.Y, TmpDC.ViewOrg)
End With
End Function
Public Function LeaveDC()
With TmpDC
TmpDC.mMode = SetMapMode(.mDC, .mMode)
Call SetWindowExtEx(.mDC, .WinExt.cx, .WinExt.cy, TmpDC.ViewExt)
Call SetWindowOrgEx(.mDC, .WinOrg.X, .WinOrg.Y, TmpDC.WinOrg)
Call SetViewportOrgEx(.mDC, .ViewOrg.X, .ViewOrg.Y, TmpDC.ViewOrg)
Call SetViewportExtEx(.mDC, .ViewExt.cx, .ViewExt.cy, TmpDC.ViewExt)
End With
End Function
Public Function UpdateDC()
Dim i As Long
For i = 1 To UBound(Dcs)
With Dcs(i)
Call BitBlt(.pDc, .DcRc.Left, .DcRc.Top, .DcRc.Right - .DcRc.Left,
.DcRc.Bottom - .DcRc.Top, .mDC, 0, 0, SRCCOPY)
End With
Next i
With CurDC
Call BitBlt(.pDc, .DcRc.Left, .DcRc.Top, .DcRc.Right - .DcRc.Left,
.DcRc.Bottom - .DcRc.Top, .mDC, 0, 0, SRCCOPY)
End With
End Function
Public Function MakeMDC(ByRef Dc As DcStruct) As Boolean
MakeMDC = False
With Dc
DeleteDC .mDC
DeleteObject .mBmp
If .hWnd = 0 Then Exit Function
.pDc = GetDC(.hWnd)
If .pDc = 0 Then Exit Function
.mDC = CreateCompatibleDC(.pDc)
If .mDC = 0 Then Exit Function
.mBmp = CreateCompatibleBitmap(.pDc, .DcRc.Right - .DcRc.Left,
.DcRc.Bottom - .DcRc.Top)
If .mBmp = 0 Then Exit Function
Call SelectObject(.mDC, .mBmp)
Call ReleaseDC(.hWnd, .pDc)
DrawBackGround .mDC, .DcRc, RGB(210, 210, 210), True
End With
MakeMDC = True
Dcs(Dc.Index) = Dc
End Function
Public Sub DrawBackGround(Dc As Long, Rc As RECTAPI, Color As Long, Optional
Border As Boolean)
'Dim tDrawR As RECT
'
'With rc
'.Left = 0: .Top = 0: .Right = DcSz.cx: .Bottom = DcSz.cy
'End With
'Debug.Print "call"
Dim hBr As Long
hBr = CreateSolidBrush(Color)
FillRect Dc, Rc, hBr
DeleteObject hBr
Dim hPen As Long
Dim hPenOld As Long
Dim tJunk As POINTAPI
Dim Trc As RECTAPI
With Trc
.Left = Rc.Left + 1
.Right = Rc.Right - 1
.Top = Rc.Top + 1
.Bottom = Rc.Bottom - 1
End With
Dim hOldBrush As Long
Dim hOldPen As Long
If Border = True Then
hOldBrush = SelectObject(Dc, GetStockObject(NULL_BRUSH))
hPen = CreatePen(0, 1, vbRed)
hOldPen = SelectObject(Dc, hPen)
Rectangle Dc, Trc.Left, Trc.Top, Trc.Right, Trc.Bottom
Call SelectObject(Dc, hOldPen)
Call SelectObject(Dc, hOldBrush)
Call DeleteObject(hPen)
End If
End Sub
' =================================== form=================================
Option Explicit
Dim WithEvents CmdAdd As VB.CommandButton
Private Sub cmdAdd_Click()
Dim TmpRc As RECTAPI
TmpRc.Left = IIf(MouseDownPt.X < MouseUpPt.X, MouseDownPt.X, MouseUpPt.X)
TmpRc.Right = IIf(MouseDownPt.X > MouseUpPt.X, MouseDownPt.X, MouseUpPt.X)
TmpRc.Top = IIf(MouseDownPt.Y < MouseUpPt.Y, MouseDownPt.Y, MouseUpPt.Y)
TmpRc.Bottom = IIf(MouseDownPt.Y > MouseUpPt.Y, MouseDownPt.Y, MouseUpPt.Y)
CurDC = AddDc(Me.hWnd, TmpRc)
If MakeMDC(CurDC) = True Then
Zoom = 500
SetDC
UpdateDC
LeaveDC
Else
MsgBox "making dc is failed"
End If
End Sub
Private Sub Form_Initialize()
Me.WindowState = 2
Me.ScaleMode = vbPixels
End Sub
Private Sub Form_Load()
InitFirst
Set CmdAdd = Controls.Add("VB.CommandButton", "Cmd1", FrmTestDC)
CmdAdd.Move 0, 50
CmdAdd.Caption = "Add"
CmdAdd.Visible = True
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single,
Y As Single)
MouseDownPt.X = X
MouseDownPt.Y = Y
ClickPt = MouseDownPt
Call DPtoLP(CurDC.mDC, ClickPt, 1&)
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single,
Y As Single)
Me.Cls
MovePt.X = X
MovePt.Y = Y
Call DPtoLP(CurDC.mDC, MovePt, 1&)
Rectangle CurDC.mDC, MovePt.X - 50, MovePt.Y - 50, MovePt.X + 50, MovePt.Y +
50
Print MovePt.X, MovePt.Y
UpdateDC
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y
As Single)
MouseUpPt.X = X
MouseUpPt.Y = Y
End Sub
'================================================================
Thanks
Amrit