Full Screen Text (On Top) and transparency

Posted on 2002-04-12
Last Modified: 2010-05-02
I am writing an activex control that I wish to enable text to be written onto the top screen.
The control itself uses pop up forms etc that remain on top.  I wish to place text on top of the controlling app.
I can of course use a text box or simple form but, I wnat it to give text notices with transparent background on top of the active application.
I have use transparent forms and have also used animated gifs on top of everything but text doesn't work.
I can write text on the screen but it can not be removed or changed easily.
I dont want a form or anything to be visible except the text with a trasparent background.
Secondly, many transparent forms simply use picture snapshots of the background. Is there a way of having an active transparent form. IE if animations are going on in the background app then they are visible. If you have a animated gif running in explorer and you place a transparent form over the top then I want to see the animation still running, not a still of it.
(I want to see the fridge light with the door closed.)
Question by:ProgramIT
  • 2
LVL 27

Expert Comment

ID: 6938513

Option Explicit
'=======Clipping text staff===============
Private Declare Function SelectClipPath Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
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 SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Private Const RGN_COPY = 5

'===========Always on top staff============
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOREDRAW = &H8

Private Sub Form_Load()
  'Don't forget set BorderStyle property to None at design time!
  Const TXT = " Cool programm" & vbCrLf & "           from" & vbCrLf & "  Cool Company" & vbCrLf & "CopyLeft by Ark"
  Dim hRgn As Long
  Font.Name = "Times New Roman"
  Font.Bold = True
  Font.Size = 60
  Width = TextWidth(TXT)
  Height = TextHeight(TXT)
  BeginPath hdc
    CurrentX = 0
    CurrentY = 0
    Print TXT
  EndPath hdc
  hRgn = PathToRegion(hdc)
  SetWindowRgn hWnd, hRgn, False
  AutoRedraw = True

'Now, you can color you text by loading any picture
'Picture = LoadPicture("c:\windows\clouds.bmp")

'or using color lines. All drowings will affect only text.

Line (1, 1)-(Width, Height / 4), vbRed, BF
Line (1, Height / 4)-(Width, Height / 2), vbBlue, BF
Line (1, Height / 2)-(Width, 3 * Height / 4), vbGreen, BF
Line (1, 3 * Height / 4)-(Width, Height), vbYellow, BF
  Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
End Sub

Private Function Window_SetAlwaysOnTop(hwnd As Long, bAlwaysOnTop As Boolean) As Boolean
   Window_SetAlwaysOnTop = SetWindowPos(hwnd, -2 - bAlwaysOnTop, 0, 0, 0, 0, SWP_NOREDRAW Or SWP_NOSIZE Or SWP_NOMOVE)
End Function

Enjoy :)
LVL 27

Accepted Solution

Ark earned 50 total points
ID: 6938515
Oops, forgot to add call to Window_SetAlwaysOnTop function at the end of Form_Load event
LVL 16

Expert Comment

ID: 6939573
A long time ago, i used this:

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 Declare Function ReleaseCapture Lib "user32" _
    () As Long
Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long
Private Const HTCAPTION = 2

Dim Texto(0 To 2) As String
Dim strLength(0 To 2) As Integer
Dim XPos(0 To 2) As Integer

Private Function GetTextRgn(strTexto As String, intCounter As Integer, XPos As Integer) As Long
    Dim hRgn1 As Long, hRgn2 As Long
    Dim rct As RECT
    'Create a path on the form's device context...
    BeginPath hdc
    TextOut hdc, XPos, 0, strTexto, intCounter 'Chr$(88) & Chr$(88), 2
    EndPath hdc
    '... convert that path to a region for our form...
    hRgn1 = PathToRegion(hdc)
    GetRgnBox hRgn1, rct
    hRgn2 = CreateRectRgnIndirect(rct)
    '... and invert the region.
    CombineRgn hRgn2, hRgn2, hRgn1, RGN_AND

    DeleteObject hRgn1
    GetTextRgn = hRgn2
End Function

Private Sub GradateColors(Colors() As Long, _
ByVal Color1 As Long, ByVal Color2 As Long)
    On Error Resume Next

    Dim i As Integer
    Dim dblR As Double, dblG As Double, dblB As Double
    Dim addR As Double, addG As Double, addB As Double
    Dim bckR As Double, bckG As Double, bckB As Double

    dblR = CDbl(Color1 And &HFF)
    dblG = CDbl(Color1 And &HFF00&) / 255
    dblB = CDbl(Color1 And &HFF0000) / &HFF00&
    bckR = CDbl(Color2 And &HFF&)
    bckG = CDbl(Color2 And &HFF00&) / 255
    bckB = CDbl(Color2 And &HFF0000) / &HFF00&
    addR = (bckR - dblR) / UBound(Colors)
    addG = (bckG - dblG) / UBound(Colors)
    addB = (bckB - dblB) / UBound(Colors)

    For i = 0 To UBound(Colors)
        dblR = dblR + addR
        dblG = dblG + addG
        dblB = dblB + addB
        If dblR > 255 Then dblR = 255
        If dblG > 255 Then dblG = 255
        If dblB > 255 Then dblB = 255
        If dblR < 0 Then dblR = 0
        If dblG < 0 Then dblG = 0
        If dblG < 0 Then dblB = 0
        Colors(i) = RGB(dblR, dblG, dblB)
End Sub

Private Sub Form_Click()
Unload Me
End Sub

Private Sub Form_DblClick()
    'Always nice to have a way out
    Unload Me
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
x As Single, Y As Single)
    'Allow dragging of the form, even
    'without a titlebar.
    SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&
End Sub

Private Sub Form_Paint()
    'Use a fancy gradient for the demo,
    'instead of that drab vbButtonFace.
    Dim Colors() As Long
    Dim Iter As Long

    Const Banding = 8

    ReDim Colors(ScaleHeight \ Banding) As Long
    GradateColors Colors(), vbWhite, vbBlack
    For Iter = 0 To ScaleHeight Step Banding
        Line (0, Iter)-(ScaleWidth, Iter + Banding), _
            Colors(Iter \ Banding), BF
End Sub

Private Sub Timer1_Timer()
Dim x As Long
Static Contador As Integer
Dim hRgn As Long
Me.Visible = True
Texto(0) = ")1998 - Done by"
strLength(0) = 15
XPos(0) = 0

Texto(1) = "Prowler_666."
strLength(1) = 12
XPos(1) = 50

Texto(2) = "Bye!"
strLength(2) = 4
XPos(2) = 200

If Contador = 3 Then Contador = 0

    hRgn = GetTextRgn(Texto(Contador), strLength(Contador), XPos(Contador))
    SetWindowRgn hwnd, hRgn, 1
    x = GetTextRgn(Texto(Contador), strLength(Contador), XPos(Contador))
    Debug.Print Texto(Contador), strLength(Contador), XPos(Contador)
    Contador = Contador + 1
End Sub


Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Pull multiple cvs files into one access table 28 65
VB6 add a minute to the date time value 8 63
Hide vba in gp 7 83
VB6 ListBox Question 4 34
I’ve seen a number of people looking for examples of how to access web services from VB6.  I’ve been using a test harness I built in VB6 (using many resources I found online) that I use for small projects to work out how to communicate with web serv…
This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

867 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now