'General Declarations Const WM_NCLBUTTONDOWN = &HA1 Const HTCAPTION = 2 Declare Function Sendmessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long Declare Sub ReleaseCapture Lib "User" () Declare Function GetactiveWindow Lib "User" () As Integer Dim Focus As Integer '////////////////////////////////////////////////// ' WINDOWBUILD '////////////////////////////////////////////////// Sub Form_GotFocus () TitleBarObject.BackColor = active_Title_BAr '////////////////////////////////////////////////// 'Events for this object: 'Load 'Unload 'Gotfocus 'LostFocus 'MouseDown 'MouseUp 'DblClick 'KeyDown 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub Form_KeyDown (KEYCODE As Integer, Shift As Integer) '////////////////////////////////////////////////// 'Events for this object: 'Load 'Unload 'Gotfocus 'LostFocus 'MouseDown 'MouseUp 'DblClick 'KeyDown 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ Dim ShiftDown, Altdown, CtrlDown Const KEY_F4 = &H73 'Const KEY_F2 = &H71 ' Define constants. Const ALT_MASK = 4 Altdown = (Shift And ALT_MASK) > 0 If KEYCODE = KEY_sPACE Then ' Display key combinations. If ShiftDown And CtrlDown And Altdown Then ElseIf ShiftDown And Altdown Then ElseIf ShiftDown And CtrlDown Then ElseIf CtrlDown And Altdown Then ElseIf ShiftDown Then ElseIf CtrlDown Then ElseIf Altdown Then picControlMenu_Mouseup 1, 0, 0, 0 ElseIf Shift = 0 Then End If End If If KEYCODE = KEY_F4 Then If Altdown Then End End If End If '////////////////////////////////////////////////// 'Events for this object: 'Load 'Unload 'Gotfocus 'LostFocus 'MouseDown 'MouseUp 'DblClick 'KeyDown 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub Form_Load () Call WindowBuild(frmMain, WindowBorder1, TitleBarObject, picControlMenu) ' Pass it the names of the objects that make up the Window.' Call WindowBuild a second time to eliminate flicker Call WindowBuild(frmMain, WindowBorder2, TitleBarObject, picControlMenu) Focus = True 'To color the window approprietly Timer1.Interval = 10 'Enable timer to catch events ' Code for "INI" File ' frmMain.Top = GetPrivateProfileInt(SECTION, "Top", 0, INIFILENAME) ' frmMain.Left = GetPrivateProfileInt(SECTION, "Left", 0, INIFILENAME) ' frmMain.Height = GetPrivateProfileInt(SECTION, "Height", Screen.Height, INIFILENAME) ' frmMain.Width = GetPrivateProfileInt(SECTION, "Width", Screen.Width, INIFILENAME) '////////////////////////////////////////////////// 'Events for this object: 'Load 'Unload 'Gotfocus 'LostFocus 'MouseDown 'MouseUp 'DblClick 'KeyDown 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub Form_LostFocus () Dim i As Integer i = GetactiveWindow() MsgBox "" + Str$(i) '////////////////////////////////////////////////// 'Events for this object: 'Load 'Unload 'Gotfocus 'LostFocus 'MouseDown 'MouseUp 'DblClick 'KeyDown 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub Form_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) If Focus = True Then TitleBarObject.BackColor = active_Title_BAr Else TitleBarObject.BackColor = active_Title_BAr End If '////////////////////////////////////////////////// 'Events for this object: 'Load 'Unload 'Gotfocus 'LostFocus 'MouseDown 'MouseUp 'DblClick 'KeyDown 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub Form_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single) Focus = True Timer1.Interval = 10 '////////////////////////////////////////////////// 'Events for this object: 'Load 'Unload 'Gotfocus 'LostFocus 'MouseDown 'MouseUp 'DblClick 'KeyDown 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub Form_Resize () WindowBuild frmMain, WindowBorder1, TitleBarObject, picControlMenu WindowBuild frmMain, WindowBorder2, TitleBarObject, picControlMenu '////////////////////////////////////////////////// 'Events for this object: 'Load 'Unload 'Gotfocus 'LostFocus 'MouseDown 'MouseUp 'DblClick 'KeyDown 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub Form_Unload (Cancel As Integer) Dim rc As Integer 'Create the INI file rc = WritePrivateProfileString(SECTION, ByVal "Top", ByVal Str$(frmMain.Top), INIFILENAME) rc = WritePrivateProfileString(SECTION, ByVal "Left", ByVal Str$(frmMain.Left), INIFILENAME) rc = WritePrivateProfileString(SECTION, ByVal "Height", ByVal Str$(frmMain.Height), INIFILENAME) rc = WritePrivateProfileString(SECTION, ByVal "Width", ByVal Str$(frmMain.Width), INIFILENAME) 'Terminate the application End '////////////////////////////////////////////////// 'Events for this object: 'Load 'Unload 'Gotfocus 'LostFocus 'MouseDown 'MouseUp 'DblClick 'KeyDown 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub picControlMenu_DblClick () Unload frmMain End '////////////////////////////////////////////////// 'Events for this object: 'DblClick 'MouseDown 'MouseUp 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub picControlMenu_Mousedown (Button As Integer, Shift As Integer, X As Single, Y As Single) Focus = True Timer1.Interval = 10 '////////////////////////////////////////////////// 'Events for this object: 'DblClick 'MouseDown 'MouseUp 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub picControlMenu_Mouseup (Button As Integer, Shift As Integer, X As Single, Y As Single) TitleBarObject.BackColor = active_Title_BAr mousepointer = 5 Focus = True Timer1.Interval = 10 PopupMenu frmDummy.mnuSystemMenu, 0, 0, 9 mousepointer = 0 '////////////////////////////////////////////////// 'Events for this object: 'DblClick 'MouseDown 'MouseUp 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub picControlMenu_Resize () picControlMenu.Picture = Image1(1).Picture '////////////////////////////////////////////////// 'Events for this object: 'DblClick 'MouseDown 'MouseUp 'Resize '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub Timer1_Timer () If Focus = True Then If GetactiveWindow() <> frmMain.hWnd Then 'Do form's lost-focus routines here. Focus = False WindowBorder1.BorderColor = Inactive_Border TitleBarObject.BackColor = inactive_Title_BAr Else Focus = True End If End If 'Only Event for this object '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub Sub TitleBarObject_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) Focus = True Timer1.Interval = 10 If Button <> 1 Then Exit Sub ' If not the left mouse button, ...exit Dim ReturnVal% ReleaseCapture ReturnVal% = Sendmessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0) Dim i As Integer i = GetactiveWindow() TitleBarObject.BackColor = active_Title_BAr '////////////////////////////////////////////////// 'Only Event for this object '////////////////////////////////////////////////// End Sub Sub WindowBuild (Frm As Form, WindowBorder As Shape, TitleBar As Label, ControlMenu As PictureBox) ControlMenu.Top = 0 'Places the menu "|-|" picture ControlMenu.Left = 0 'in the UpperLeft '*****************Create a border for the window****************** WindowBorder.Width = Frm.ScaleWidth WindowBorder.Height = Frm.ScaleHeight WindowBorder.Left = 0 WindowBorder.Top = 0 Rem******Other effects can be added with the' WindowBorder.BorderWidth property Rem******This will create a shadow effect******************************************* Rem*WindowBorder.BorderWidth = 3; WindowBorder.Left = -1; WindowBorder.Top = -1 TitleBar.Width = Frm.ScaleWidth + 1 ' Makes the title bar 1 pixel larger than the width of the form Rem Change this to adjust the height of the titlebar.* '******************************************************* TitleBar.Height = 12 ' '******************************************************* 'Note: You must make a custom BMP for the Control Menu, ' if you change this. Dim offset As Integer offset = 2 ControlMenu.Height = TitleBar.Height - offset ControlMenu.Width = TitleBar.Height TitleBar.Left = -offset TitleBar.Top = -offset End Sub