Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0125: Auf dem Desktop mit GDI-Werkzeugen zeichnen

 von 

Beschreibung 

Wer Bildschirmschoner oder ähnliches werkeln möchte, kommt nicht drum herum. Hier wird neben dem eigentlichen Benutzen des Desktops als Leinwand, auch der Umgang mit diversen GDI Werkzeugen, wie Linien, Punkten und Stiften, gezeigt.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

BitBlt, CreateCompatibleBitmap, CreateCompatibleDC, CreateDCA (CreateDC), CreatePen, DeleteDC, DeleteObject, LineTo, SelectObject, SetPixel

Download:

Download des Beispielprojektes [2,52 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Optionsfeld-Steuerelement "Option2"
' Steuerelement: Optionsfeld-Steuerelement "Option1"
' Steuerelement: Schaltfläche "Command1"

Option Explicit

Private Declare Function CreatePen Lib "gdi32" (ByVal _
        nPenStyle As Long, ByVal nWidth As Long, ByVal _
        crColor As Long) As Long
        
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As _
        Long, ByVal x As Long, ByVal y As Long) As Long
        
Private Declare Function CreateDC Lib "gdi32" Alias _
        "CreateDCA" (ByVal lpDriverName As String, ByVal _
        lpDeviceName As String, ByVal lpOutput As String, _
        ByVal lpInitData As Any) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" _
        (ByVal hDC As Long) As Long
        
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC _
        As Long) As Long
        
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 SetPixel Lib "gdi32" (ByVal hDC _
        As Long, ByVal x As Long, ByVal y As Long, ByVal _
        crColor As Long) As Long
               
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
        (ByVal hDC As Long, ByVal nWidth As Long, ByVal _
        nHeight As Long) As Long
        
Private Declare Function BitBlt Lib "gdi32" (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

Const SRCCopy = &HCC0020

Private Sub Command1_Click()
  Dim hDC&, hDCBuffer&, hBmp&, hPen, hObject&
  Dim DeskWidth&, DeskHeight&, Z&, Col&, Max&
    
    Max = 5000 + (Option1.Value + 1) * 500000

    'Desktopgröße ermitteln
    DeskWidth = Screen.Width / Screen.TwipsPerPixelX
    DeskHeight = Screen.Height / Screen.TwipsPerPixelY
    
    'Desktop in anderer Bitmap zwischenpuffern
    hDC = CreateDC("DISPLAY", 0&, 0&, 0&)
    hDCBuffer = CreateCompatibleDC(hDC)
    hBmp = CreateCompatibleBitmap(hDC, DeskWidth, DeskHeight)
    Call SelectObject(hDCBuffer, hBmp)
    Call BitBlt(hDCBuffer, 0, 0, DeskWidth, DeskHeight, _
                hDC, 0, 0, SRCCopy)

    'Vollkrakeln
    For Z = 1 To Max
      Col = RGB(256 * Rnd, 256 * Rnd, 256 * Rnd)
      If Option1.Value Then
        hPen = CreatePen(0, 20, Col)
        hObject = SelectObject(hDC, hPen)
        Call LineTo(hDC, CInt(DeskWidth * Rnd), _
                    CInt(DeskHeight * Rnd))
        DeleteObject (hObject)
      Else
        Call SetPixel(hDC, CInt(DeskWidth * Rnd), _
                      CInt(DeskHeight * Rnd), Col)
      End If
    Next Z
    
    'Desktop zurückkopieren
    Call BitBlt(hDC, 0, 0, DeskWidth, DeskHeight, hDCBuffer, _
                0, 0, SRCCopy)
    
    'Gerätekontexte wieder löschen
    Call DeleteDC(hDCBuffer)
    Call DeleteDC(hDC)
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 6 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von swat am 20.03.2007 um 16:54

Nachtrag:
Aufruf erfolgt so:

cx = 50
cy = 100
Call MoveToEx(hdc,cx,cy,0&)

Kommentar von swat am 20.03.2007 um 16:12

@hinde:

Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As _
Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) _
As Long

Kommentar von Alexander am 17.09.2004 um 14:17

einfach ein genialer Tipp!

Funzt sogar mit VBA(MS-Excel) auf WinNT ;)

Kommentar von hinde am 24.10.2003 um 17:32

Die Verwendung von MoveTo erzeugt eine Fehlermeldung: DLL Einsprungpunkt MoveTo in gdi32 nicht gefunden.
Wie kann ich eine Linie mit Start und Endkoordinaten auf dem Desktop zeichnen ?
Vielen Dank für einen Vorschlag bereits im Voraus.

Kommentar von MS am 12.09.2003 um 17:46

Antwort an hinde:

mit MoveTo(hDC, x, y)
Declare analog zu LineTo

Kommentar von hinde am 10.09.2003 um 12:36

Hallo,

ein Tolles Beispiel !
Aber wie kann der Startpunkt für eine Linie festgelegt werden ?