[VB6] Cambiare il font corrente con API

[mvent]

come si fa?
sto usando l'API drawtext sullo schermo, NON SUL FORM.
riesco ad impostare il colore di sfondo del testo e il colore del testo tramite le API SetTextColor e SetBkColor.
mi manca di poter scegliere il font (arial, courier, tahoma, eccetera)

ma non riesco a trovare un API per farlo.
qualcuno sa aiutarmi?

:-)
saluti,
mauro v.
=====================

[oregon]

Ma in VB6 ?

E che vuoi dire "non sul form" ?

[mvent]

sì in vb6(scusate ho dimenticato di scriverlo nel titolo)
vuol dire che scrivo sullo schermo, al di fuori di finestre windows.

si può impostare il colore del testo che scrivo con l'api drawtext, ma non so scegliere il font (ed è molto importante)

[oregon]

Scrivi direttamente sul desktop ... ? Strana applicazione ...

Comunque, mostra un attimo il codice, per far qualche prova ...

[mvent]

non sul desktop...sullo schermo! guarda tu stesso:
metti tutto in modulo(senza form)
su proprieta del progetto metti oggetto di avvio =sub main
per uscire dal programma tieni premuto ESC.

Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public MSG As String, KEW As RECT
Public Const VK_ESCAPE = &H1B
Public Const DT_CENTER = &H1

Sub Main()
App.TaskVisible = False
If App.PrevInstance Then
MSG = MsgBox("Il programma è già attivo.", vbInformation, "TITPROG99")
Exit Sub
End If
Call Matrix(1, 3, vbGreen, 100, "---")
End Sub

Private Sub Matrix(DOVE As Byte, MODO As Byte, COLORE As Long, VELOCITA As Integer, SCRITTA As String)
Dim I As Long, J As Long, CHIAMAID As Long, ALTEZZA As Long, LARGHEZZA As Long
Dim COL As Long, COL2 As Long, CaSo As Long, SESTINA As Integer, FINE As Boolean
On Error GoTo Gest_Err
'Me.ScaleMode = vbPixels
Select Case DOVE
Case 1
CHIAMAID = GetDC(0) 'prende l'handle dello schermo
ALTEZZA = (Screen.Height / 15)
LARGHEZZA = (Screen.Width / 15)
Case 2
'CHIAMAID = Me.hdc 'prende l'handle del form
'ALTEZZA = Me.ScaleHeight
'LARGHEZZA = Me.ScaleWidth
Case Else
'CHIAMAID = Me.hdc 'prende l'handle del form
'ALTEZZA = Me.ScaleHeight
'LARGHEZZA = Me.ScaleWidth
End Select
'Cls
For J = 1 To ALTEZZA
For I = 1 To LARGHEZZA
Call SetPixel(CHIAMAID, I, J, vbBlack)
Next I
Next J
Select Case MODO
Case 1
'questo non ti serve
Case 2
'questo non ti serve
Case 3 'alfanumeri con drawtext
Call SetBkColor(CHIAMAID, vbBlack)
Call SetTextColor(CHIAMAID, COLORE)

FINE = False
I = 0
Do While Not FINE
If GetAsyncKeyState(VK_ESCAPE) = -32767 Then
'se è uguale a -32767 significa che ESC è premuto
Call Beep(500, 1000)
FINE = True
End If
Call Sleep(VELOCITA)
KEW.Left = 1
KEW.Right = LARGHEZZA
KEW.Top = I
KEW.Bottom = I + 15
I = IIf(I > ALTEZZA, 0, I + 19)
SCRITTA = ""
SESTINA = 0
For COL = 1 To 72
SESTINA = SESTINA + 1
Randomize
Select Case COL Mod 5
Case 0
CaSo = Int((61 - 47 + 1) * Rnd + 47)
Case 1
CaSo = Int((92 - 64 + 1) * Rnd + 64)
Case 2
CaSo = Int((122 - 97 + 1) * Rnd + 97)
Case 3
CaSo = Int((250 - 224 + 1) * Rnd + 224)
Case Else
CaSo = Int((250 - 224 + 1) * Rnd + 224)
End Select
SCRITTA = SCRITTA & Chr(CaSo) & " "
If SESTINA > 7 Then
SESTINA = 0
SCRITTA = SCRITTA & " "
End If
Next COL
SCRITTA = Trim(SCRITTA)
Call DrawText(CHIAMAID, SCRITTA, Len(SCRITTA), KEW, DT_CENTER)
Loop
Call Sleep(2000)
End Select
Exit Sub
Gest_Err:
MSG = MsgBox(Err.Description, vbExclamation, "TITPROG99")
End Sub

[oregon]

Sì ... utilizzando l' hwnd del desktop ... e' lo stesso ...

In realta' si usa la costante

Public Const HWND_DESKTOP = 0

e si chiama la

GetDC(HWND_DESKTOP)

che *non restituisce* l'handle dello schermo ma l'handle al device context del desktop (non e' importante la differenza ai fini dell'applicazione) ...

Attenzione al fatto che l'hdc (handle del device context) cosi' ottenuto va rilasciato con la API ReleaseDC quando non serve piu' ...

Per l'uso di un font diverso, devi crearne uno con la CreateFont e selezionare l'handle al font ottenuto tramite la SelectObject conservando l'handle dell'handle del font precedente.
Questo perche', al termine, deve essere selezionato il vecchio font e distrutto quello appena creato con la DeleteObject.

[mvent]

sei un grande, ci ho messo 6 ore per riuscire a trovare quello che tu mi hai trovato in pochi minuti....
:-)

riguardo la createfont
ha circa 2 milioni di parametri...
dove le piglio quelle informazioni per impostare come courier new?
ma poi qual'è più semplice, createfont o CreateFontIndirect?
che succede se non uso la releasedc?!

[oregon]

Puoi usare la CreateFont. Certo, ha qualche parametro, ma se devi creare un font, quelle cose gliele devi dire !

Allora, ti servono queste costanti e queste API

Public Const CLIP_DEFAULT_PRECIS = 0
Public Const PROOF_QUALITY = 2
Public Const DEFAULT_PITCH = 0

Public 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
Public Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Nella Sub Matrix devi dichiarare queste variabili

Dim oldFont As Long, newFont As Long

la chiamata alla GetDC e' bene che sia

CHIAMAID = GetDC(HWND_DESKTOP)

dopo la SetTextColor devi scrivere

newFont = CreateFont(-MulDiv(10, GetDeviceCaps(CHIAMAID, LOGPIXELSY), 72), 0, 0, 0, _
                     FW_NORMAL, True, False, False, DEFAULT_CHARSET, _
                     OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, _
                     PROOF_QUALITY, DEFAULT_PITCH, "Times New Roman")
oldFont = SelectObject(CHIAMAID, newFont)

e alla fine, dopo la End Select

SelectObject CHIAMAID, oldFont
DeleteObject newFont

P.S. attenzione a non aprire messaggi come quello che hai aperto per "attirare" la mia attenzione ... questa non e' una chat e dovresti avere pazienza e attendere i messaggi di risposta ...
Non voglio fare il "moderatore" ma avvertirti per evitare una "moderazione" (che mi sembra inevitabile ...)

[mvent]

quel messaggio lo volevo postare in coda a questo, ma ho sbagliato e ho creato un nuovo thread!!ho provato a cancellarlo ma non è possibile...spero i moderatori non si incazzino troppo...mi giustifico con la tarda ora....
riguardo il codice che mi hai postato, ti ringrazio, lo provo domattina, perchè ora non ce la faccio più, sto morendo dal sonno,

grazie ti faccio sapere!!
:-)
mauro

[oregon]

Bella questa ... sono rimasto in piedi a buttare giu' il codice che avevi tanta fretta di vedere e ... tu vai a letto ...

'notte ...