Delphi-PRAXiS - Delphi Bildschirmlupe - Bereich unter Formular ermitteln

Zitat:

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