Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Text direkt auf dem Bildschirm ausgeben
zurück: Spezielle Klassen - Teil 5 - Application weiter: Bildschirmschoner und Energiesparmodus unterdrücken Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Information Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
Isabelle :-)
Menschin


Verfasst am:
09. Mai 2013, 00:15
Rufname:
Wohnort: Westlicher Spiralarm der Galaxis


Text direkt auf dem Bildschirm ausgeben - Text direkt auf dem Bildschirm ausgeben

Nach oben
       Version: Office XP (2002)

Hallöchen,

eine kleine Spielerei mit API-Funktionen um einen Text ohne Userform oder MsgBox auf dem Bildschirm auszugeben. Da das Ganze nur über Bildschirmkoordinaten zu steuern ist, kann es natürlich die Standardboxen von VBA nicht ersetzen. Eine Beschreibung der Funktionen und deren Parameter findet ihr in der MSDN-Library:

http://msdn.microsoft.com/en-us/library/windows/desktop/dd144824(v=vs.85).aspx

Code:
Option Explicit

Private Declare Function CreateRectRgn Lib "gdi32.dll" ( _
    ByVal nLeftRect As Long, _
    ByVal nTopRect As Long, _
    ByVal nRightRect As Long, _
    ByVal nBottomRect As Long) As Long
Private Declare Function GetRgnBox Lib "gdi32.dll" ( _
    ByVal hRgn As Long, _
    ByRef lpRect As RECT) As Long
Private Declare Function FillRect Lib "user32.dll" ( _
    ByVal hdc As Long, _
    ByRef lpRect As RECT, _
    ByVal hBrush As Long) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal nBkMode As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" ( _
    ByVal crColor As Long) As Long
Private Declare Function TextOutA Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal lpString As String, _
    ByVal nCount As Long) As Long
Private Declare Function SetTextColor Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal crColor As Long) As Long
Private Declare Function SetTextCharacterExtra Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal nCharExtra As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" ( _
    ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal hObject As Long) As Long
Private Declare Function CreateFontA Lib "gdi32.dll" ( _
    ByVal nHeight As Long, _
    ByVal nWidth As Long, _
    ByVal nEscapement As Long, _
    ByVal nOrientation As Long, _
    ByVal fnWeight As Long, _
    ByVal fdwItalic As Long, _
    ByVal fdwUnderline As Long, _
    ByVal fdwStrikeOut As Long, _
    ByVal fdwCharSet As Long, _
    ByVal fdwOutputPrecision As Long, _
    ByVal fdwClipPrecision As Long, _
    ByVal fdwQuality As Long, _
    ByVal fdwPitchAndFamily As Long, _
    ByVal lpszFontName As String) As Long
Private Declare Function GetWindowDC Lib "user32.dll" ( _
    ByVal hWnd As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" ( _
    ByVal dwMilliseconds As Long)

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900

Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const HANGEUL_CHARSET = 129
Private Const CHINESEBIG5_CHARSET = 136
Private Const OEM_CHARSET = 255

Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_STRING_PRECIS = 1
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_STROKE_PRECIS = 3
Private Const OUT_TT_PRECIS = 4
Private Const OUT_DEVICE_PRECIS = 5
Private Const OUT_RASTER_PRECIS = 6
Private Const OUT_TT_ONLY_PRECIS = 7
Private Const OUT_OUTLINE_PRECIS = 8

Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_CHARACTER_PRECIS = 1
Private Const CLIP_STROKE_PRECIS = 2
Private Const CLIP_MASK = &HF
Private Const CLIP_LH_ANGLES = 16
Private Const CLIP_TT_ALWAYS = 32
Private Const CLIP_EMBEDDED = 128

Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2
Private Const NONANTIALIASED_QUALITY = 3
Private Const ANTIALIASED_QUALITY = 4
Private Const CLEARTYPE_QUALITY = 5

Private Const FF_DONTCARE = 0
Private Const FF_ROMAN = 16
Private Const FF_SWISS = 32
Private Const FF_MODERN = 48
Private Const FF_SCRIPT = 64
Private Const FF_DECORATIVE = 80

Private Const TRANSPARENT = 1
Private Const OPAQUE = 2

Public Sub ShowText()

    Const OUTPUT_TEXT = "Hallo Office-Lösung"

    Dim lngDeviceContext As Long
    Dim lngFont As Long, lngFontOld As Long
    Dim lngBrush As Long, lngRegion As Long
    Dim udtRectangular As RECT

    'Gerätekontext des Excelfensters holen
    lngDeviceContext = GetWindowDC(Application.hWnd)

    'Pinsel erzeugen mit grüner Farbe
    lngBrush = CreateSolidBrush(RGB(0, 255, 0))

    'Rechteck erzeugen
    lngRegion = CreateRectRgn(200, 190, 1300, 310)

    'Koordinaten des Rechtecks in benutzerdefinieten Datentyp holen
    Call GetRgnBox(lngRegion, udtRectangular)

    'Rechteck ausmalen
    Call FillRect(lngDeviceContext, udtRectangular, lngBrush)

    'Hintergrund der Schrift transparent
    Call SetBkMode(lngDeviceContext, TRANSPARENT)

    'Textfarbe auf Rot setzen
    Call SetTextColor(lngDeviceContext, RGB(255, 0, 0))

    'gesperrter Text (Abstände zwischen den Buchstaben)
    Call SetTextCharacterExtra(lngDeviceContext, 5)

    'Schrift festlegen
    lngFont = CreateFontA(100, 0, 0, 0, FW_BOLD, 0, 0, 0, _
        ANSI_CHARSET, OUT_CHARACTER_PRECIS, CLIP_DEFAULT_PRECIS, _
        CLEARTYPE_QUALITY, FF_MODERN, "Verdana")

    'vorhergehendes Schriftformat auslesenund durch neues ersetzen
    lngFontOld = SelectObject(lngDeviceContext, lngFont)

    'Text auf dem Bildschirm ausgeben
    Call TextOutA(lngDeviceContext, 250, 200, OUTPUT_TEXT, Len(OUTPUT_TEXT))

    'damit taucht das Ganze tatsächlich auf
    DoEvents

    '3 Sekunden warten
    Call Sleep(3000)

    'vorhergehendes Schriftformat wiederherstellen
    Call SelectObject(lngDeviceContext, lngFontOld)

    'alle Objekte löschen
    Call DeleteObject(lngFont)
    Call DeleteObject(lngRegion)
    Call DeleteObject(lngBrush)

    'und so verschwindet das Ganze wieder
    Application.ScreenUpdating = True

End Sub

_________________
LG Isi

Die Mitgliedschaft im Forum erhöht deine Chance auf eine Antwort von mir um 99,999%
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: Nächster Wert vom Resultat suchen und ausgeben 10 hbborer 916 13. Okt 2005, 16:35
rainberg Nächster Wert vom Resultat suchen und ausgeben
Keine neuen Beiträge Excel Formeln: ein berechnetes Feld in einen Text einbinden 3 tom2ba 1224 11. Aug 2005, 10:52
ae ein berechnetes Feld in einen Text einbinden
Keine neuen Beiträge Excel Formeln: Text multiplizieren 3 tschwarz 1567 20. Jul 2005, 22:10
mumpel Text multiplizieren
Keine neuen Beiträge Excel Formeln: Den zum Maximalwert zugehörigen Text anzeigen? 6 Florian 1523 01. Jul 2005, 11:50
Florian Den zum Maximalwert zugehörigen Text anzeigen?
Keine neuen Beiträge Excel Formeln: SUMME wenn in der Spalte Text und Zahl steht ??? 8 Inge 1750 30. Mai 2005, 11:40
Inge SUMME wenn in der Spalte Text und Zahl steht ???
Keine neuen Beiträge Excel Formeln: Kann man 4 Übereinstimungen in einer 2 Tabelle ausgeben?? 2 Blue_Whirlwind 790 03. Mai 2005, 20:08
Arnim Kann man 4 Übereinstimungen in einer 2 Tabelle ausgeben??
Keine neuen Beiträge Excel Formeln: Spalten Buchstarben ausgeben lassen ? 2 slicki 916 20. Apr 2005, 00:31
Hübi Spalten Buchstarben ausgeben lassen ?
Keine neuen Beiträge Excel Formeln: unterscheidung zwischen text und zahlen in einer Zelle 5 hmmmmm??? 1166 02. Feb 2005, 12:13
hmmmmm??? unterscheidung zwischen text und zahlen in einer Zelle
Keine neuen Beiträge Excel Formeln: WENN DANN mit Text und Zahlen.... 2 Gast 1978 11. Jan 2005, 16:06
pega_de WENN DANN mit Text und Zahlen....
Keine neuen Beiträge Excel Formeln: Text in andere Tabelle übertragen 2 freddy-krueger 3737 02. Dez 2004, 11:16
freddy-krueger Text in andere Tabelle übertragen
Keine neuen Beiträge Excel Formeln: Formel als Text in Nachbarzelle kopieren 6 blauvogel 1129 19. Okt 2004, 16:54
blauvogel Formel als Text in Nachbarzelle kopieren
Keine neuen Beiträge Excel Formeln: Formatierung einer anderen Zelle wenn in der einen ein Text 2 Gast 5007 01. Sep 2004, 11:04
Gast Formatierung einer anderen Zelle wenn in der einen ein Text
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Web Editor Forum