Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > comp.lang.basic.visual.misc > #1890

Selection rectangle flickers under Win8

Show all headers | View raw

Hi all,

I create a selection rectangle by API.
Works ok so far, but...

When I drag it to a positive direction all is ok.
Dragging in at least one negative direction makes a flicker.

I can observe this strange effect only under Win8.
It doesn't occure under WinXp/32 or Win7/64.

Something must be wrong, but I don't find it.

Perhaps some can take a look at it?
Would help me out.

See code below.


Thanks,
Karl

--- Form1 ---
Option Explicit
Dim IsDrawing As Boolean


Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Dim sx As Long, sy As Long
    sx = ScaleX(X, ScaleMode, vbPixels)
    sy = ScaleY(Y, ScaleMode, vbPixels)
    IsDrawing = True
    SelectRect.top = sy
    SelectRect.left = sx
    SelectRect.Bottom = sy
    SelectRect.Right = sx
    StartX = sx
    StartY = sy
    Call CreateSelectWindow(Me)

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim sx As Long, sy As Long

If (IsDrawing) Then
    sx = ScaleX(X, Me.ScaleMode, vbPixels)
    sy = ScaleY(Y, Me.ScaleMode, vbPixels)
    
    If (sx > 65000) Then
        sx = 0
    End If
    
    If (sy > 65000) Then
        sy = 0
    End If
    
    If (sx < StartX) Then
        SelectRect.left = sx
        SelectRect.Right = StartX
    Else
        SelectRect.left = StartX
        SelectRect.Right = sx
    
    End If
    If (sy < StartY) Then
        SelectRect.top = sy
        SelectRect.Bottom = StartY
    Else
        SelectRect.top = StartY
        SelectRect.Bottom = sy
    End If
    
    DrawSelectRect SelectRect.left, SelectRect.top, SelectRect.Right, SelectRect.Bottom
    
End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If (IsDrawing) Then
    IsDrawing = False
    Call DestroySelectWindow
End If
End Sub
--- Form1 End ---

--- Module1 ---
Option Explicit

Private Type rect
    left    As Long
    top     As Long
    Right   As Long
    Bottom  As Long
End Type

Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private Type size
  cx As Long
  cy As Long
End Type

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type


Private Type CREATESTRUCT
        lpCreateParams As Long
        hInstance As Long
        hMenu As Long
        hWndParent As Long
        cy As Long
        cx As Long
        Y As Long
        X As Long
        style As Long
        lpszName As String
        lpszClass As String
        ExStyle As Long
End Type
Private Const WS_EX_TRANSPARENT = &H20&
Private Const WS_EX_LAYERED = &H80000
Private Const WS_POPUP = &H80000000
Private Const WS_VISIBLE = &H10000000

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type


Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function UpdateLayeredWindow Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long, pptDst As POINTAPI, pSize As size, ByVal hdcSrc As Long, pptSrc As POINTAPI, ByVal crKey As Long, pBlend As BLENDFUNCTION, ByVal dwFlags As Long) As Long Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Any, ByVal Handle As Long, ByVal dw As Long) As Long Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long Private 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 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
                                        (ByVal hWnd As Long, _
                                         ByVal nIndex As Long, _
                                         ByVal dwNewLong As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
                                        (ByVal hWnd As Long, _
                                         ByVal nIndex As Long) As Long


Private Const DIB_RGB_COLORS As Long = 0 Private Const WS_THICKFRAME = &H40000
Private Const GWL_EXSTYLE       As Long = (-20)
Private Const GWL_STYLE         As Long = (-16)
Private Const AC_SRC_OVER = &H0
Private Const ULW_ALPHA = &H2       ' Used to draw the window with alpha-blending.


Dim mDragwnd As Long
Dim mDragHdc As Long

Public SelectRect As rect
Public StartX As Long, StartY As Long
Dim frmobj As Form


Public Function CreateSelectWindow(ParentForm As Form) As Boolean

Dim CS As CREATESTRUCT
Dim swidth, sheight As Long
Dim lStyle As Long
Dim lExStyle As Long


Set frmobj = ParentForm
sheight = 1
swidth = 1
mDragwnd = CreateWindowEx(WS_EX_TRANSPARENT, "STATIC", "", WS_VISIBLE Or WS_POPUP, -1, _
                                    -1, 0, 0, frmobj.hWnd, 0, App.hInstance, CS) mDragHdc = GetDC(mDragwnd)

lStyle = GetWindowLong(mDragwnd, GWL_STYLE) 'lStyle = lStyle And Not (WS_CAPTION Or WS_MINIMIZE Or WS_MAXIMIZE Or WS_SYSMENU) lStyle = lStyle Or WS_THICKFRAME SetWindowLong mDragwnd, GWL_STYLE, lStyle

lExStyle = GetWindowLong(mDragwnd, GWL_EXSTYLE) 'lExStyle = lExStyle And Not (WS_EX_DLGMODALFRAME Or WS_EX_WINDOWEDGE) lExStyle = lExStyle Or WS_EX_LAYERED SetWindowLong mDragwnd, GWL_EXSTYLE, lExStyle

End Function

Public Function DrawSelectRect(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long) As Boolean
    Dim tempBI As BITMAPINFO            ' Holds the bitmap information
    Dim swidth As Long
    Dim sheight As Long
    Dim hdc As Long
    Dim hWnd As Long
    Dim ppt1 As POINTAPI
    Dim m_mainSurfaceDC As Long
    Dim m_backSurfaceDC As Long
    Dim m_mainSurfaceBitmap As Long
    Dim m_srcPoint As POINTAPI
    Dim m_windowSize As size
    Dim m_blendFunc As BLENDFUNCTION
    Dim w, h As Long
    
    w = frmobj.ScaleX(frmobj.Width, frmobj.ScaleMode, vbPixels)
    h = frmobj.ScaleY(frmobj.Height, frmobj.ScaleMode, vbPixels)
    
    If X2 > w - 4 Then
        X2 = w - 4
    End If
    If Y2 > h - 4 Then
        Y2 = h - 4
    End If
    If Y1 > h - 4 Then
        Y1 = h - 4
    End If
    
    ppt1.X = X1
    ppt1.Y = Y1
    ClientToScreen frmobj.hWnd, ppt1
    swidth = X2 - X1
    sheight = Y2 - Y1

    hWnd = mDragwnd
    hdc = GetDC(hWnd)

    m_mainSurfaceDC = CreateCompatibleDC(hdc)
    m_backSurfaceDC = CreateCompatibleDC(hdc)

    With tempBI.bmiHeader
        .biSize = Len(tempBI.bmiHeader)
        .biBitCount = 32    ' Each pixel is 32 bit's wide
        .biHeight = sheight   ' Height of the form
        .biWidth = swidth     ' Width of the form
        .biPlanes = 1   ' Always set to 1
        .biSizeImage = .biWidth * .biHeight * (.biBitCount / 8)
    End With
    m_mainSurfaceBitmap = CreateDIBSection(m_mainSurfaceDC, tempBI, DIB_RGB_COLORS, ByVal 0, 0, 0)
    SelectObject m_mainSurfaceDC, m_mainSurfaceBitmap

    Dim hOldPen As Long, hOldBrush As Long
    Dim hPen As Long, hBrush As Long

    hPen = CreatePen(6, 1, RGB(&H81, &H9F, &HF7))
    'hPen = CreatePen(5, 1, RGB(&H81, &H9F, &HF7))
    hBrush = CreateSolidBrush(RGB(&H81, &H9F, &HF7))

    hOldPen = SelectObject(m_mainSurfaceDC, hPen)
    hOldBrush = SelectObject(m_mainSurfaceDC, hBrush)
    Rectangle m_mainSurfaceDC, 0, 0, swidth, sheight
    SelectObject m_mainSurfaceDC, hOldPen
    SelectObject m_mainSurfaceDC, hOldBrush

    DeleteObject hPen
    DeleteObject hBrush

    m_windowSize.cx = swidth
    m_windowSize.cy = sheight

    m_srcPoint.X = 0
    m_srcPoint.Y = 0

    With m_blendFunc
        .AlphaFormat = 0
        .BlendFlags = 0
        .BlendOp = AC_SRC_OVER
        .SourceConstantAlpha = 100
    End With
    UpdateLayeredWindow hWnd, hdc, ppt1, m_windowSize, m_mainSurfaceDC, _
                            m_srcPoint, 0, m_blendFunc, ULW_ALPHA

    DeleteDC m_backSurfaceDC
    DeleteDC hdc
    DeleteObject m_mainSurfaceBitmap
    DeleteDC m_mainSurfaceDC

End Function

Public Function DestroySelectWindow() As Boolean DeleteDC mDragHdc DestroyWindow mDragwnd End Function
--- Module1 End ---

Back to comp.lang.basic.visual.misc | Previous | Next | Find similar | Unroll thread

Thread

Selection rectangle flickers under Win8 spanker.leach@googlemail.com - 2013-10-11 07:24 -0700

csiph-web