Kirjautuminen

Haku

Tehtävät

Keskustelu: Ohjelmointikysymykset: VB6: Tekstin piirtoa näytölle GDI:llä

Blaze [11.06.2004 03:27:47]

#

Mahtaisko joku osata vähän selventää, miten tämä homma toimii?
Saan tekstiä kiltisti näytölle TextOut -apilla, mutta miten tuon fonttia, väriä, kokoa jne. voi vaihtaa? RTFM:lyni antaa ymmärtää, että CreateFont + SelectObject -yhdistelmällä tuo onnistuisi, mutta enpä minä vaan saa toimimaan, vaan teksti piirtyy aina oletusfontilla (MS Sans Serif?), oletuskoolla (8pt?), oletusvärillä (musta), oletustaustalle (valkoinen).

Viritelmäni tähän asti näyttää jokseenkin tältä (Karsin tavaraa aika reilusti, toivottavasti mitään oleellista ei jäänyt pois...):

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetWindowDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32.dll" Alias "TextOutA" (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 SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long

Public SettingMessageInterval As Long
Public SettingDisplayString As String

Dim Font As Long
Dim OldFont As Long

Private Const FW_NORMAL = 400
Private Const DEFAULT_CHARSET = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const FF_DONTCARE = 0
Private Const TRANSPARENT = 1

Private Sub Main()
    SettingMessageInterval = 3000
    SettingDisplayString = "Moi!"
    Call SetTimer(frmSettings.hwnd, 1&, SettingMessageInterval, AddressOf ShowMessage)
End Sub

Private Sub CreateFontObject()
    Font = CreateFont(48&, 0&, 0&, 0&, FW_NORMAL, 0&, 0&, 0&, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_DONTCARE, "Times New Roman")
    OldFont = SelectObject(GetWindowDC(0&), Font)
End Sub

Private Sub DeleteFontObject()
    Call SelectObject(GetWindowDC(0&), OldFont)
    Call DeleteObject(Font)
End Sub

Public Sub ShowMessage(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    Dim Position As POINTAPI

    Call GetCursorPos(Position)
    CreateFontObject
    SetBkMode GetWindowDC(0&), TRANSPARENT
    Call TextOut(GetWindowDC(0&), Position.X, Position.Y, SettingDisplayString, Len(SettingDisplayString))
    DeleteFontObject
End Sub

ShowMessagea siis kutsutaan sopivin väliajoin ja se piirtää viestin hiiren kursorin kohdalle.

Huomauttakaahan toki myös, jos lähestymistapani asiaan on totaalisen väärä.

Kaikkea apua arvostetaan (kehno käännös any help appreciatedista).

Edit: ihmehän se olisi, jos näin pitkä viesti olisi editoimatta mennyt :)

zacura [11.06.2004 18:20:16]

#

Työpöydän DC pitää ensin hakea GetWindowDC:llä ja piirron jälkeen vapauttaa ReleaseDC:llä. Näin sain itse toimimaan, koodiasin tosin delphillä mutta pitäisi periaatteessa tomia samalla lailla VB:ssä.

Win 32 SDK kirjoitti:

After painting is complete, the ReleaseDC function must be called to release the device context. Not releasing the window device context has serious effects on painting requested by applications.

Tässä asian ydin Delphillä:

 DC := GetWindowDC(0);
 SettingDisplayString := 'Heippa';
 Font := CreateFont(48, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_DONTCARE, 'Times New Roman');

 OldFont := SelectObject(DC, Font);

 SetBkMode(DC, TRANSPARENT);
 TextOut(DC, 10, 10, SettingDisplayString, Length(SettingDisplayString));

 SelectObject(DC, OldFont);
 DeleteObject(Font);
 ReleaseDC(0,DC);

edit: koodia...

Blaze [11.06.2004 19:03:40]

#

zacura kirjoitti:

Työpöydän DC pitää ensin hakea GetWindowDC:llä ja piirron jälkeen vapauttaa ReleaseDC:llä.

Kas, tuo teki tempun. Kiitoksia.

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Tietoa sivustosta