(Gast)
n/a Beiträge
|
Re: Bildschirmlupe - Bereich unter Formular ermitteln
2. Jan 2009, 09:36
Zitat von turboPASCAL:
Sie funktioniert, teilweise. Nach ein paar Scekunden schiesst sich das Programm ohne eine Fehlermeldung.
Den Desktophintergrund wird mit dem Prg. nicht angezeigt.
Wie arbeitet denn das Teil ?
Bei mir wird alles angezeigt incl. Desktop auf XP/SP2.
Hmm glaube aber du hast Vista.
Arbeiten tut es mit Standard API's
CreateRoundRectRgn
DeleteObject
GetCursorPos
GetModuleHandle
GetProcAddress
GetWindowDC
ReleaseDC
SetWindowPos
SetWindowRgn
StretchBlt
und einen Timer.. 50ms geht aber auch in realzeit also 1ms
mit 0% CPU auslastung.
Hab das Teil mal als Plugin (VB) für meinen Mediaplayer geschrieben.
Der Source !! VB
Hab keine lust das jetzt zu übersetzen dürfte aber nicht schwer sein da es nu um API
und Koordinaten geht.
Delphi-Quellcode:
Option Explicit
# Const Rounded = True ' False = wird als Rechteck angezeigt
Private Const Magnify As Long = 5 'Magnify Faktor
Private Const ViewSize As Long = 40 ' Größe des Areals zu Magnify (in pixel)
Private Const ViewSize2 As Long = ViewSize \ 2
Private Const DestSize As Long = ViewSize * Magnify
Private Const DestCenter As Long = DestSize \ 2
Private Const CrossCenter As Long = DestCenter + Magnify \ 2 + (Magnify And 1)
Private Const Border As Long = 1
Private ScrXMax As Long
Private ScrYMax As Long
Private Type tPoint
x As Long
y As Long
End Type
Private CursorPos As tPoint
Private PrevPos As tPoint
Private Cnt As Long
Private xPos As Long
Private yPos As Long
Private Const hWndDesktop As Long = 0
Private hDCDesktop As Long
Private hRgn As Long
Private Const HWND_TOPMOST As Long = -1
Private Const SWP_NOSIZE As Long = 1
Private Const SWP_NOMOVE As Long = 2
Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As tPoint) As Long
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function SetWindowPos Lib "user32.dll" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDstDC As Long, ByVal xDst As Long, ByVal yDst As Long, ByVal nDstWidth As Long, ByVal nDtsHeight 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 Long
Private Sub Form_Load()
If App.PrevInstance Then
Beep 333, 100
Beep 222, 222
Unload Me
Else
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
hDCDesktop = GetWindowDC(hWndDesktop)
Width = ScaleX(DestSize + Border + Border, vbPixels, vbTwips)
Height = Width
Show
tmrRefresh_Timer
#If Rounded Then '------------------------------------------------------------------
xPos = ScaleWidth
hRgn = CreateRoundRectRgn(2, 2, xPos, xPos, xPos, xPos)
SetWindowRgn hwnd, hRgn, True
# End If ' ---------------------------------------------------------------------------
With Screen
ScrXMax = ScaleX(.Width, vbTwips, vbPixels) - ViewSize
ScrYMax = ScaleY(.Height, vbTwips, vbPixels) - ViewSize
End With
App.TaskVisible = False
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
If hDCDesktop Then
ReleaseDC hWndDesktop, hDCDesktop
End If
If hRgn Then
DeleteObject hRgn
End If
End Sub
Private Sub tmrRefresh_Timer()
GetCursorPos CursorPos
With CursorPos
If .x <> PrevPos.x Or .y <> PrevPos.y Or Cnt = 0 Then
PrevPos = CursorPos
If .x = 0 And .y = 0 Then
Unload Me
Else
xPos = ScaleX(.x + ViewSize2, vbPixels, vbTwips)
yPos = ScaleY(.y + ViewSize2, vbPixels, vbTwips)
If xPos + Width > Screen.Width Then
xPos = Screen.Width - Width
End If
If yPos + Height > Screen.Height Then
yPos = Screen.Height - Height
End If
If xPos = Screen.Width - Width And yPos = Screen.Height - Height Then
xPos = ScaleX(.x - ViewSize2, vbPixels, vbTwips) - Width
yPos = ScaleY(.y - ViewSize2, vbPixels, vbTwips) - Height
End If
Move xPos, yPos
xPos = .x - ViewSize2
yPos = .y - ViewSize2
Cls
StretchBlt hDC, Border, Border, DestSize, DestSize, hDCDesktop, xPos, yPos, ViewSize, ViewSize, vbSrcCopy
Line (CrossCenter, CrossCenter - 7)-(CrossCenter, CrossCenter + 8), vbRed
Line (CrossCenter - 7, CrossCenter)-(CrossCenter + 8, CrossCenter), vbRed
#If Rounded Then '------------------------------------------------------------------
DrawWidth = 2
DrawMode = vbCopyPen
Circle (DestCenter - 1, DestCenter - 1), DestCenter - 2, vbBlack
DrawWidth = 1
DrawMode = vbMergePenNot
# End If ' ---------------------------------------------------------------------------
End If
End If
Cnt = (Cnt + 1) Mod 16
End With
End Sub
Bei Magnify 1 und Viewsize 80 wird alles unterhalb der Form angezeigt im Oroginal Maßstab.
vbPixels := 15
mit Cls wird der Hintergrund gelöscht und dann mit StretchBlt neu gezeichnet.
Das andere ist selbsterklärend.
gruss Emil
|