GFPopUpWindow/PopUpWindowfrm.frm

VERSION 5.00
Begin VB.Form PopUpWindowfrm
   BorderStyle     =   0 'Kein
   Caption         =   "Form1"
   ClientHeight    =   2205
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2445
   LinkTopic       =   "Form1"
   ScaleHeight     =   2205
   ScaleWidth      =   2445
   ShowInTaskbar   =   0 'False
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.Timer GFPopUpWindowTimer
      Enabled         =   0 'False
      Interval        =   100
      Left            =   0
      Top             =   0
   End
   Begin VB.CommandButton Command1
      Caption         =   "A useless command"
      Height          =   375
      Left            =   240
      TabIndex        =   0
      Top             =   660
      Width           =   1815
   End
End
Attribute VB_Name = "PopUpWindowfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Copy to any form that is meant to be displayed as a 'GFPopUpWindow'.
'GFPopUpWindow
Private Declare Function GetForegroundWindow Lib "user32" () As Long
'GFPopUpWindow_CreateShadow
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode 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
'ProgramGetMousePos[X, Y]
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
'GFSetWindowOnTop
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
'GFSetWindowOnTop
Const HWND_TOPMOST = ‑1
Const HWND_NOTOPMOST = ‑2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
'ProgramGetMousePos[X, Y]
Private Type POINTAPI
    x As Long
    y As Long
End Type
'GFPopUpWindow_CreateShadow
'Public Type POINTAPI
'    x As Long
'    y As Long
'End Type
'GFPopUpWindowStruct
Private Type GFPopUpWindowStruct
    PopUpWindowRgnHandle As Long
End Type
Dim GFPopUpWindowStructVar As GFPopUpWindowStruct

'*************************************GFPOPUPWINDOW*************************************
'NOTE: copy the following code and GFPopUpWindowTimer to a form with the
'BorderStyle 2 and call GFPopWindow_Show to display the form as a GFPopUpWindow.
'The form will hide itself when it lost the focus (API function used, VB events did not work).

Private Sub GFPopUpWindowTimer_Timer()
    'on error resume next
    If Not (GetForegroundWindow() = Me.hwnd) Then
        Call GFPopUpWindow_Hide
    End If
End Sub

Public Sub GFPopUpWindow_Show()
    'on error resume next
    'preset
    Me.Visible = False
    Me.Enabled = False
    Me.Left = ProgramGetMousePosX * Screen.TwipsPerPixelX
    Me.Top = ProgramGetMousePosY * Screen.TwipsPerPixelY
    'verify
    If (Me.Left + Me.Width ‑ 1) > (Screen.Width ‑ 1) Then Me.Left = (Screen.Width ‑ 1) ‑ Me.Width + 1
    If Me.Left < 0 Then Me.Left = 0
    If (Me.Top + Me.Height ‑ 1) > (Screen.Height ‑ 1) Then Me.Top = (Screen.Height ‑ 1) ‑ Me.Height + 1
    If Me.Top < 0 Then Me.Top = 0
    'begin
    Call GFPopUpWindow_PolyRgn_Enable(GFPopUpWindowStructVar, Me)
    Call GFPopUpWindow_CreateShadow(Me)
    Me.Enabled = True
    Me.Visible = True
    Me.Refresh
    Call GFSetWindowOnTop(Me)
    GFPopUpWindowTimer.Enabled = True
End Sub

Public Sub GFPopUpWindow_Hide()
    'on error resume next
    GFPopUpWindowTimer.Enabled = False
    Call GFPopUpWindow_PolyRgn_Disable(GFPopUpWindowStructVar, Me)
    Call GFRemoveWindowFromTop(Me)
    Me.Visible = False
    Me.Enabled = False
    Me.Refresh
End Sub

Private Sub GFPopUpWindow_CreateShadow(ByRef PopUpWindow As Form)
    'on error resume next 'call to create a window frame
    '
    'NOTE: this form must be at least 15 pixels 'larger' than its context because
    'there will be a 'shadow' around the window that has a thickness of 15 pixels
    '(at right and bottom form sides only).
    '
    'begin
    PopUpWindow.AutoRedraw = True
    PopUpWindow.ScaleMode = vbTwips
    PopUpWindow.Line (PopUpWindow.Width ‑ 15 * Screen.TwipsPerPixelX, 15 * Screen.TwipsPerPixelY)‑(PopUpWindow.Width, PopUpWindow.Height), 0, BF
    PopUpWindow.Line (15 * Screen.TwipsPerPixelX, PopUpWindow.Height ‑ 15 * Screen.TwipsPerPixelY)‑(PopUpWindow.Width, PopUpWindow.Height), 0, BF
    PopUpWindow.Refresh
End Sub

Private Sub GFPopUpWindow_PolyRgn_Enable(ByRef GFPopUpWindowStructVar As GFPopUpWindowStruct, ByRef PopUpWindow As Form)
    'on error resume next 'call to create and apply poly rgn to passed window
    Dim PopUpWindowRgnPointArray(0 To 7) As POINTAPI
    'preset
    PopUpWindowRgnPointArray(0).x = 0: PopUpWindowRgnPointArray(0).y = 0
    PopUpWindowRgnPointArray(1).x = (PopUpWindow.Width / Screen.TwipsPerPixelX) ‑ 15: PopUpWindowRgnPointArray(1).y = 0
    PopUpWindowRgnPointArray(2).x = (PopUpWindow.Width / Screen.TwipsPerPixelX) ‑ 15: PopUpWindowRgnPointArray(2).y = 15
    PopUpWindowRgnPointArray(3).x = (PopUpWindow.Width / Screen.TwipsPerPixelX): PopUpWindowRgnPointArray(3).y = 15
    PopUpWindowRgnPointArray(4).x = (PopUpWindow.Width / Screen.TwipsPerPixelX): PopUpWindowRgnPointArray(4).y = (PopUpWindow.Height / Screen.TwipsPerPixelY)
    PopUpWindowRgnPointArray(5).x = 15: PopUpWindowRgnPointArray(5).y = (PopUpWindow.Height / Screen.TwipsPerPixelY)
    PopUpWindowRgnPointArray(6).x = 15: PopUpWindowRgnPointArray(6).y = (PopUpWindow.Height / Screen.TwipsPerPixelY) ‑ 15
    PopUpWindowRgnPointArray(7).x = 0: PopUpWindowRgnPointArray(7).y = (PopUpWindow.Height / Screen.TwipsPerPixelY) ‑ 15
    'reset
    If Not (GFPopUpWindowStructVar.PopUpWindowRgnHandle = 0) Then Call DeleteObject(GFPopUpWindowStructVar.PopUpWindowRgnHandle) 'reset
    'begin
    GFPopUpWindowStructVar.PopUpWindowRgnHandle = CreatePolygonRgn(PopUpWindowRgnPointArray(0), 8, 1)
    Call SetWindowRgn(PopUpWindow.hwnd, GFPopUpWindowStructVar.PopUpWindowRgnHandle, True)
End Sub

Private Sub GFPopUpWindow_PolyRgn_Disable(ByRef GFPopUpWindowStructVar As GFPopUpWindowStruct, ByRef PopUpWindow As Form)
    'on error resume next 'call to free up some GDI memory
    Call SetWindowRgn(PopUpWindow.hwnd, 0, True)
    If Not (GFPopUpWindowStructVar.PopUpWindowRgnHandle = 0) Then Call DeleteObject(GFPopUpWindowStructVar.PopUpWindowRgnHandle) 'reset
End Sub

'*********************************END OF GFPOPUPWINDOW**********************************
'***********************************GENERAL FUNCTIONS***********************************

Private Function ProgramGetMousePosX() As Long
    On Error Resume Next 'the format is: pixels
    Dim ProgramGetMousePosXTemp As Long
    Dim CurrentMousePos As POINTAPI
    ProgramGetMousePosXTemp = GetCursorPos(CurrentMousePos)
    ProgramGetMousePosX = CurrentMousePos.x
End Function

Private Function ProgramGetMousePosY() As Long
    On Error Resume Next 'the format is: pixels
    Dim ProgramGetMousePosYTemp As Long
    Dim CurrentMousePos As POINTAPI
    ProgramGetMousePosYTemp = GetCursorPos(CurrentMousePos)
    ProgramGetMousePosY = CurrentMousePos.y
End Function

Private Function GFSetWindowOnTop(ByVal WindowOrFormName As Form) As Long
    'on error resume next
    GFSetWindowOnTop = SetWindowPos(WindowOrFormName.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
    WindowOrFormName.Refresh
End Function

Private Function GFRemoveWindowFromTop(ByVal WindowOrFormName As Form) As Long
    'on error resume next
    GFRemoveWindowFromTop = SetWindowPos(WindowOrFormName.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
    WindowOrFormName.Refresh
End Function


[END OF FILE]