OnScreen display text

Hvad med søgeordet "text overlay"

mvh.

Christian

det er ikke ligesom volume display men prøv:


Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function TextOut Lib "gdi32" 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 InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long) As Long

Private Sub Form_Load()
  Timer1.Interval = 10
End Sub

Private Sub Form_Unload(Cancel As Integer)
  InvalidateRect 0, ByVal 0, 0
End Sub

Private Sub Timer1_Timer()
Dim strString As String
  strString = "Cool, www.eksperten.dk"
  TextOut GetWindowDC(0), 10, 10, strString, Len(strString)
End Sub

Hmm, jeg synes den kræver lidt meget... når jeg så kører Quake 3 så hakker det forholdsvist meget... måske en anden metode?

Det lykkedes mig at finde en anden og bedre metode, men tak alligevel, du får sku' pointsne... du skal bare lige "svare"...

Det lyder godt, må man se metode man kan jo altid lærere noget. :-)

Jeg bruger DirectX istedet... lidt indviklet, men søg på directdraw.

Kan man gøre så baggrunden er gennemsigtig?

Nope, ikke med det jeg har fundet. Den opretter et DirectX "firkant" område som man kan skrive i.

ok.... jeg fandt noget kode der gjorde at man kunne gøre det gennemsigtigt, men den bruger "TextOut"...

...har du et link, jeg vil da gerne se det.
Men det gør heller ikke noget, for så har man svært ved at læse hvad der står... det kan iøvrigt godt være man kan vælge en baggrundsfarve der er transperant... men ved ikke lige how :)

Det er sindsygt svært at læse, men her får du lige hele programmet...

Option Explicit

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

Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" 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 EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetRgnBox Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) _
        As Long

Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, _
        ByVal hSrcRgn1 As Long, _
        ByVal hSrcRgn2 As Long, _
        ByVal nCombineMode As Long) As Long

Private Const RGN_AND = 1
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 Function GetTextRgn() As Long
        Dim hRgn1 As Long, hRgn2 As Long
        Dim rct As RECT

        'Create a path for the window's shape
        BeginPath hdc
        TextOut hdc, 0, 0, "You've got mail", Len("You've got mail")
        EndPath hdc

        '... Convert the path to a region...
        hRgn1 = PathToRegion(hdc)
        GetRgnBox hRgn1, rct
        hRgn2 = CreateRectRgnIndirect(rct)
        CombineRgn hRgn2, hRgn2, hRgn1, RGN_AND
        'Return the region handle
        DeleteObject hRgn1
        GetTextRgn = hRgn2
End Function

Private Sub Form_DblClick()
        'Need to be able to close the form
        Unload Me
End Sub


Private Sub Form_Load()
        Dim hRgn As Long
        Me.Font.Name = "Tahoma"
        Me.Font.Size = 24
        Me.FontBold = True

        hRgn = GetTextRgn()
        SetWindowRgn hwnd, hRgn, 1
End Sub

nu er den ikke svært at læse. :-)

Option Explicit

Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" 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 SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Sub Form_Click()
  End
End Sub

Private Sub Form_Load()
    Me.FontName = "Tahoma"
    Me.FontSize = 100
    Me.FontBold = True
    Me.BackColor = &HFFFF& 'Gul
    Me.Height = 3000
    Me.Width = 10000
    Timer1.Interval = 1000 'Timer
    Call Timer1_Timer 'Timer
End Sub

Private Sub Timer1_Timer()
Dim hRgn As Long
Dim strText As String
  strText = Time 'Tekst

  BeginPath Me.hdc
  TextOut Me.hdc, 0, 0, strText, Len(strText)
  EndPath Me.hdc

  hRgn = PathToRegion(Me.hdc)
  SetWindowRgn Me.hWnd, hRgn, True
  DeleteObject hRgn
End Sub

Når du kører scriptet... bruger programmet så ikke mere og mere ram? Hos mig der stiger den hele tiden for tilsidst næsten at "crashe" maskinen.
(lukker dog bare med Ctrl+alt+del)

jeg syntes ikke jeg kan se at det bruger noget, bruger du Systemovervågning hvelket element tilføjer du så?

Jeg bruger bare Joblisten til at se hvor meget det enkelt program bruger af ram, og så kan jeg se at VB6 bruger mere og mere...

hvor finder jeg den (Joblisten)

i win2000, ctrl+alt+delete og så jobliste

Ok, men ikke win98. :(

Ingen problemer med xp

Jeg har faktisk heller ikke nogle problemer når man bruger Begin og EndPath, men bruger man kun TextOut så suger den rammen ud af maskinen :)

hmm ved mig bliver den ikke ovenpå når jeg starter f.eks et spil...hverken i opengl eller d3d

panton/shj's kode jeg snakker om her

Hmm, det fungerer ellers fint her, bortset fra at det blinker når spil kører med høj framerate, og så suger den ca. 1 mb ram hvert 10 sekund... :) det kan jeg ikke bruge til noget