setting program to display always on top of other windows without having the focus?

[madscijr]

Maybe you can do something with these programs.
The first always keeps the window in the foreground and also gives it focus.
With the second you can make the window invisible.
You just have to think about how you can shoot it again if you can't see it.

I think those will do the trick - thanks! 

Here are my tests... 


"KEEPFOCUS.BAS":

Code: (Select All)

' setting program to display always on top of other windows without having the focus? (page 2)
' https://qb64phoenix.com/forum/showthread.php?tid=2697&pid=25429#pid25429

' #19
' Steffan-68 - Member
' 05-21-2024, 02:54 PM
' Maybe you can do something with these programs.
' The first always keeps the window in the foreground and also gives it focus.
' ...

Option _Explicit
_Title "KeepFocus" : _Delay .1

Declare Dynamic Library "user32"
    Sub ShowWindow (ByVal hWnd As _Offset, Byval nCmdShow As Long)
End Declare

Dim hwnd%&
Dim iCount As Integer
Dim fps As Integer

' GET HANDLE TO THE PROGRAM WINDOW
Do
    hwnd%& = _WindowHandle
Loop Until hwnd%&

' SHOW INSTRUCTIONS
Cls
Print "Set Window Active Test"
Print "----------------------"
Print "When the test begins, the program will keep taking the focus,"
Print "and beep once a second to remind you it's still running."
Print
Print "The program will stop when you press the Escape key."
Print
Print "Press Enter to start test"
Sleep

Cls
Locate 5, 10
Print "PRESS ESCAPE TO QUIT"

fps = 30
iCount = 0
Do
    If _WindowHasFocus = 0 Then
        _ScreenIcon
        ShowWindow hwnd%&, 1
    End If

    ' Count and update the screen with counter
    Locate 10, 10
    Print _Trim$(Str$(iCount)) + "     "
    iCount = iCount + 1

    ' Beep once every second
    If iCount > fps Then
        Beep
        iCount = 0
    End If

    If _KeyDown(27) Then
        Exit Do ' leave loop when ESC key pressed
    End If

    _Limit fps
Loop

System

"INVISIBLE.BAS":

Code: (Select All)

' setting program to display always on top of other windows without having the focus? (page 2)
' https://qb64phoenix.com/forum/showthread.php?tid=2697&pid=25429#pid25429

' #19
' Steffan-68 - Member
' 05-21-2024, 02:54 PM
' Maybe you can do something with these programs.
' ...
' With the second you can make the window invisible.
' You just have to think about how you can shoot it again if you can't see it.

Option _Explicit
_Title "Invisible" : _Delay .1

Declare Dynamic Library "user32"
    Function SetLayeredWindowAttributes& (ByVal hwnd As _Offset, Byval crKey As Long, Byval bAlpha As _Unsigned _Byte, Byval dwFlags As Long)
    Function GetWindowLong& Alias "GetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long)
    Function SetWindowLong& Alias "SetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long, Byval dwNewLong As Long)
End Declare

' Needed for acquiring the hWnd of the window
Declare Library
    Function FindWindow& (ByVal ClassName As _Offset, WindowName$) ' To get hWnd handle
End Declare

Const FALSE = 0
Const TRUE = Not FALSE

Const cInvisible = 0
Const cTransparent = 160
Const cVisible = 255

Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)

Dim iCount As Integer
Dim fps As Integer
Dim sTriggerFile As String

Dim MyHwnd As _Offset ' _Integer64
Dim Level As _Unsigned _Byte

' GET HANDLE TO THE PROGRAM WINDOW
Do
    MyHwnd = _WindowHandle ' FindWindow(0, "Translucent window test" + CHR$(0))
Loop Until MyHwnd

' BASE NAME OF TRIGGER FILE OFF THE EXECUTABLE
sTriggerFile = m_ProgramPath$ + m_ProgramName$ + ".DELETE-TO-CLOSE"

' SHOW INSTRUCTIONS
Cls
Print "Invisible Window Test"
Print "---------------------"
Print "When the test begins, the program window will turn invisible,"
Print "and beep once a second to remind you it's still running."
Print
Print "The program will stop when if it detects that trigger file "
Print Chr$(34) + NameOnly$(sTriggerFile, "\") + Chr$(34)
Print "is not present."
Print
Print "Deleting the above file from the program folder "
Print "or pressing Escape will cause it to exit."
Print
Print "Press Enter to start test"
Sleep

' CREATE TRIGGER FILE
Open sTriggerFile For Output As #1
Print #1, "Deleting this file will cause program " + m_ProgramName$ + " to stop running."
Close #1

' TURN WINDOW INVISIBLE
SetWindowOpacity MyHwnd, cInvisible

' LOOK FOR FILE AND EXIT WHEN IT ISN'T FOUND
Cls
Locate 5, 10
Print "PRESS A TO SHOW WINDOW"
Locate 8, 10
Print "PRESS B FOR TRANSPARENT"
Locate 11, 10
Print "PRESS C TO HIDE WINDOW"
Locate 20, 10
Print "PRESS ESCAPE TO QUIT"

SetWindowOpacity MyHwnd, Level
fps = 30
iCount = 0
Do
    ' Count and update the screen with counter
    Locate 10, 10
    Print _Trim$(Str$(iCount)) + "     "
    iCount = iCount + 1

    ' Beep once every second
    If iCount > fps Then
        Beep
        iCount = 0
    End If

    ' IF USER PRESSES A THEN SHOW WINDOW
    If _KeyDown(65) Or _KeyDown(97) Then
        SetWindowOpacity MyHwnd, cVisible
    End If

    ' IF USER PRESSES B THEN MAKE WINDOW TRANSPARENT
    If _KeyDown(66) Or _KeyDown(98) Then
        SetWindowOpacity MyHwnd, cTransparent
    End If

    ' IF USER PRESSES C THEN HIDE WINDOW
    If _KeyDown(67) Or _KeyDown(99) Then
        SetWindowOpacity MyHwnd, cInvisible
    End If

    ' IF USER PRESSES ESCAPE THEN EXIT
    If _KeyDown(27) Then
        DeleteFile sTriggerFile
        Exit Do ' leave loop when ESC key pressed
    End If

    _Limit fps
Loop While _FileExists(sTriggerFile)

' EXIT
'End
System

' /////////////////////////////////////////////////////////////////////////////
' hWnd = handle to window to set opacity for
' Level = 0 TO 255, 0=totally invisible, 128=transparent, 255=100% solid

Sub SetWindowOpacity (hWnd As _Offset, Level As _Unsigned _Byte)
    Const cIndex = -20
    Const LWA_ALPHA = &H2
    Const WS_EX_LAYERED = &H80000

    Dim lngMsg As Long
    Dim lngValue As Long

    'Function GetWindowLong& Alias "GetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long)
    lngMsg = GetWindowLong(hWnd, cIndex)
    lngMsg = lngMsg Or WS_EX_LAYERED

    'Function SetWindowLong& Alias "SetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long, Byval dwNewLong As Long)
    lngValue = SetWindowLong(hWnd, cIndex, lngMsg)

    'Function SetLayeredWindowAttributes& (ByVal hwnd As _Offset, Byval crKey As Long, Byval bAlpha As _Unsigned _Byte, Byval dwFlags As Long)
    lngValue = SetLayeredWindowAttributes(hWnd, 0, Level, LWA_ALPHA)
End Sub ' SetWindowOpacity

' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618&pid=24683#pid24683
' a740g
' #5
' 04-24-2024, 06:05 AM
'
' There are no commands to directly make copies or backup of files.
' But you could write one with a few lines of code like:
'
' Copies src to dst
' Set overwite to true if dst should be overwritten if present
Sub CopyFile (src As String, dst As String, overwrite As _Byte)
    If _FileExists(src) Then
        If Not _FileExists(dst) Or (_FileExists(dst) And overwrite) Then
            _WriteFile dst, _ReadFile$(src)
        End If
    End If
End Sub ' CopyFile

' /////////////////////////////////////////////////////////////////////////////
' Convert a value to string and trim it (because normal Str$ adds spaces)

Function cstr$ (myValue)
    'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
    cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$

' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618

Sub DeleteFile (sFile As String)
    If _FileExists(sFile) Then
        'Shell "DELETE " + sFile
        'Shell "del " + sFile
        Kill sFile
    End If
End Sub ' DeleteFile

' /////////////////////////////////////////////////////////////////////////////

Function FileExt$ (sFile As String)
    Dim iPos As Integer
    iPos = _InStrRev(sFile, ".")
    If iPos > 0 Then
        If Len(sFile) > 1 Then
            If iPos > 1 Then
                FileExt$ = Right$(sFile, Len(sFile) - iPos)
            Else
                ' dot is first character, return everything after it
                FileExt$ = Right$(sFile, Len(sFile) - 1)
            End If
        Else
            ' file only has one character, the dot, the file extension is blank
            FileExt$ = ""
        End If
    Else
        ' no dot found, the file extension is blank
        FileExt$ = ""
    End If
End Function ' FileExt$

' /////////////////////////////////////////////////////////////////////////////

Function NameOnly$ (sFile As String, sSlash As String)
    Dim iPos As Integer
    'sFile = Replace$(sFile, "/", "\")

    iPos = _InStrRev(sFile, sSlash)
    If iPos > 0 Then
        If Len(sFile) > 1 Then
            If iPos > 1 Then
                NameOnly$ = Right$(sFile, Len(sFile) - iPos)
            Else
                ' slash is first character, return everything after it
                NameOnly$ = Right$(sFile, Len(sFile) - 1)
            End If
        Else
            ' file only has one character, the slash, name is blank
            NameOnly$ = ""
        End If
    Else
        ' slash not found, return the entire thing
        NameOnly$ = sFile
    End If
End Function ' NameOnly$

' /////////////////////////////////////////////////////////////////////////////

Function NoExt$ (sFile As String)
    Dim iPos As Integer
    iPos = _InStrRev(sFile, ".")
    If iPos > 0 Then
        If Len(sFile) > 1 Then
            If iPos > 1 Then
                NoExt$ = Left$(sFile, iPos - 1)
            Else
                ' dot is first character, removing it returns blank!
                ' our version will just return the name unchanged
                ' but you can return blank if you prefer
                NoExt$ = sFile
            End If
        Else
            ' file only has one character, the dot, removing it returns blank!
            ' our version will just return the name unchanged
            ' but you can return blank if you prefer
            NoExt$ = sFile
        End If
    Else
        ' no dot found
        ' return the name unchanged
        NoExt$ = sFile
    End If
End Function ' NoExt$

' /////////////////////////////////////////////////////////////////////////////

Function PathOnly$ (sFile As String, sSlash As String)
    Dim iPos As Integer
    'sFile = Replace$(sFile, "/", "\")

    iPos = _InStrRev(sFile, sSlash)
    If iPos > 0 Then
        If Len(sFile) > 1 Then
            If iPos > 1 Then
                PathOnly$ = Left$(sFile, iPos)
            Else
                ' slash is first character, so not much of a path, return blank
                PathOnly$ = ""
            End If
        Else
            ' file only has one character, the slash, name is blank
            PathOnly$ = ""
        End If
    Else
        ' slash not found, so not a path, return blank
        PathOnly$ = ""
    End If
End Function ' PathOnly$

' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=TRUE appends to file, else overwrites it.

' Returns blank if successful else returns error message.

' Example:
' ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = ProgramPath$ + ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, FALSE)

Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
    Dim sError As String: sError = ""

    If (bAppend = TRUE) Then
        If _FileExists(sFileName) Then
            Open sFileName For Append As #1 ' opens an existing file for appending
        Else
            sError = "Error in PrintFile$ : File not found. Cannot append."
        End If
    Else
        Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
    End If
   
    If Len(sError) = 0 Then
        ' NOTE: WRITE places text in quotes in the file
        'WRITE #1, x, y, z$
        'WRITE #1, sText

        ' PRINT does not put text inside quotes
        Print #1, sText

        Close #1
    End If

    PrintFile$ = sError
End Function ' PrintFile$

' /////////////////////////////////////////////////////////////////////////////
' Fastest way is always to just read the whole life at once and then parse it.

Function ReadFile$ (sFileName As String, sDefault As String)
    Dim x$
    If _FileExists(sFileName) Then
        Open sFileName For Binary As #1
        x$ = Space$(LOF(1))
        Get #1, 1, x$
        Close #1
        ReadFile$ = x$
    Else
        ReadFile$ = sDefault
    End If
End Function ' ReadFile$

' /////////////////////////////////////////////////////////////////////////////

Function ReadFileLineByLine$ (sFileName As String, sDefault As String)
    Dim sResult As String: sResult = ""
    Dim sLine As String
   
    ' FOUND FILE?
    If _FileExists(sFileName) = TRUE Then
        ' OPEN FILE
        Open sFileName For Input As #1
       
        ' READ EACH LINE
        While Not EOF(1)
            ' READ NEXT LINE
            Line Input #1, sLine ' read entire text file line
            'INPUT #1, sChar ' read a character?
           
            sResult = sResult + sLine + Chr$(13)
        Wend
        Close #1
    Else
        ' FILE NOT FOUND
        sResult = sDefault
    End If
   
    ReadFileLineByLine$ = sResult
End Function ' ReadFileLineByLine$

' /////////////////////////////////////////////////////////////////////////////

Function ReadFileCharByChar$ (sFileName As String, sDefault As String)
    Dim sResult As String: sResult = ""
    Dim sChar As String
   
    ' FOUND FILE?
    If _FileExists(sFileName) = TRUE Then
        ' OPEN FILE
        Open sFileName For Input As #1
       
        ' READ EACH LINE
        While Not EOF(1)
            Input #1, sChar ' READ NEXT CHARACTER
            'Line Input #1, sLine ' READ NEXT LINE
            sResult = sResult + sChar
        Wend
        Close #1
    Else
        ' FILE NOT FOUND
        sResult = sDefault
    End If
   
    ReadFileCharByChar$ = sResult
End Function ' ReadFileCharByChar$

' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
'   Purpose:  A library of custom functions that transform strings.
'   Author:   Dustinian Camburides (dustinian@gmail.com)
'   Platform: QB64 (www.qb64.org)
'   Revision: 1.6
'   Updated:  5/28/2012

'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.

Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
    ' VARIABLES:
    Dim Text2 As String
    Dim Find2 As String
    Dim Add2 As String
    Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
    Dim strBefore As String ' The characters before the string to be replaced.
    Dim strAfter As String ' The characters after the string to be replaced.

    ' INITIALIZE:
    ' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
    Text2 = Text1
    Find2 = Find1
    Add2 = Add1

    lngLocation = InStr(1, Text2, Find2)

    ' PROCESSING:
    ' While [Find2] appears in [Text2]...
    While lngLocation
        ' Extract all Text2 before the [Find2] substring:
        strBefore = Left$(Text2, lngLocation - 1)

        ' Extract all text after the [Find2] substring:
        strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))

        ' Return the substring:
        Text2 = strBefore + Add2 + strAfter

        ' Locate the next instance of [Find2]:
        lngLocation = InStr(1, Text2, Find2)

        ' Next instance of [Find2]...
    Wend

    ' OUTPUT:
    Replace$ = Text2
End Function ' Replace$