Forums Neueste Beiträge
 

Auswahlrechteck flackert unter Win8

09/10/2013 - 11:42 von spanker.leach | Report spam
Hallo zusammen,

ich erzeuge per API ein Auswahlrechteck.
Das wird mit der Maus gezogen und dann wird festgestellt, was sich darin befindet, ausgewertet usw.
Funktioniert auch alles.

Es geht hier nur um das Auswahlrechteck selbst.
Wenn ich es von oben links nach unten rechts ziehe ist die Darstellung ok.
Ziehe ich es jedoch ins negative flackert die Kante, an der begonnen wurde.
Beim Ziehen in zwei negative Richtungen flackern beide Kanten.

Bei meinen Tests tritt das Flackern nur unter Win8 auf.
Unter XP32 und Win7/64 sieht es in jedem Falle perfekt aus.

Ich gehe davon aus, dass irgendetwas falsch ist oder zumindest besser sein könnte, aber ich komme nicht dahinter.

Vielleicht hat jemand Lust, sich die Sache einmal anzusehen?
Im Folgenden der Code in Form1, danach Module1.


Danke und einen schönen Tag,
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 Ende

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 Ende
 

Lesen sie die antworten

#1 Anton Bayer
10/10/2013 - 16:26 | Warnen spam
Ich kann mich dunkel an ein àhnliches Problem unter XP erinnern, bei dem im
Rahmen eines Viewports (eine PicBox auf der andern) eine Vergrößerung des
Ausschnitts nach rechts bzw. unten die eine PicBox 'ruhig' blieb, wàhrend
bei einer Verkleinerung der Ausschnitt neu gezeichnet wurde und er deshalb
flackerte. Wenn ich richtig dran bin habe ich damals das eine Window dann
eingefroren.

Ähnliche fragen