|
|
Please support our sponsor:
Form And Control Special Effects
How to get 3D Forms, MsgBoxes & CMDialogs using the CTL3D.DLL.
How to draw 3D offset bevels around controls.
How to draw 3D raised and recessed bevels on a form.
How to draw a drop or back shadow on any control on a form.
How to create a 3D embossed effect on text using label controls.
Got a useful snippet you'd like to share? Submit it here.
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to get 3D Forms, MsgBoxes & CMDialogs using the CTL3D.DLL.
'Note: This has only been tested with VB 3 & VB 4-16, if you convert
'this for use with other versions please let me know.-Burt Abreu
'-------------------------------------------------------------------
' The following code gives Forms, with Borderstyle = Fixed Double,
' that nice 3D appearance. Also included, is automatic subclassing
' for MsgBoxes, InPutBoxes and CMDialogs to give them the 3D look.
' ** Important Note:
' Although fully functional, using this code can cause AE's or GPF's
' if the program goes down prematurely due any other error.
' Best case scenario, program crashes. Worst case - Windows crashes!
' It is therefore, recommended that you only add this code to your app
' when it is near completion and is bug-free. ;)
' In a .BAS module at the following Constants, API's and 3 routines:
' Already declared in C:\VB\CTL3D.BAS
' Module Code:
Option Explicit
' CTL3D API calls
' All APIs on one single line.
Declare Function Ctl3dAutoSubclass% Lib "Ctl3D.DLL" (ByVal hInst%)
Declare Function Ctl3dRegister% Lib "Ctl3D.DLL" (ByVal hInst%)
Declare Function Ctl3dUnregister% Lib "Ctl3D.DLL" (ByVal hInst%)
Declare Function Ctl3dSubclassDlgEx% Lib "Ctl3D.DLL" (ByVal hWnd%, ByVal dFlags&)
' Other API Calls for the Forms.
Declare Function GetWindowLong& Lib "User" (ByVal hWnd%, ByVal nIndex%)
Declare Function GetWindowWord% Lib "User" (ByVal hWnd%, ByVal nIndex%)
Declare Function SetWindowLong& Lib "User" (ByVal hWnd%, ByVal nIndex%,
ByVal dwNewLong&)
Global Const FIXED_DOUBLE = 3
Global Const DS_MODALFRAME = &H80&
Global Const GWL_STYLE = (-16)
Global Const GWW_HINSTANCE = (-6)
Global Const CTL3D_ALL = &HFFFF
' Menu APIs for adjusting the 3D Dialog box system menu
' All APIs on one single line.
Declare Function GetSystemMenu% Lib "User" (ByVal hWnd%, ByVal bRevert%)
Declare Function RemoveMenu% Lib "User" (ByVal hMenu%, ByVal nPosition%,
ByVal wFlags%)
Global Const MF_BYPOSITION = &H400
' Colors
Global Const COLOR_BLACK = &H0&
Global Const COLOR_LIGHT_GRAY = &HC0C0C0
Global Const COLOR_DARK_GRAY = &H808080
Global Const COLOR_WHITE = &HFFFFFF
Sub DlgSysMenu (fm As Form)
'This procedure modifies the menu for the dialog box.
'The form musthave the MinButton and MaxButton set
'to false if you leave the ControlBox property set to true.
'Otherwise, Restore, Maximize, and Minimize will stay on...
Dim hSysMenu%, suc%
' Obtain the handle to the forms System menu
hSysMenu% = GetSystemMenu(fm.hWnd, False)
' Remove all but the MOVE and CLOSE options.
' The menu items must be removed starting with
' the last menu item.
suc% = RemoveMenu(hSysMenu, 8, MF_BYPOSITION) 'Switch to
suc% = RemoveMenu(hSysMenu, 7, MF_BYPOSITION) 'Separator
suc% = RemoveMenu(hSysMenu, 5, MF_BYPOSITION) 'Separator
End Sub
Sub FormToDialog (frm As Form)
'This procedure makes the dialog box (Form) appear 3D.
Dim hWnd As Integer
Dim iResult As Integer
Dim lStyle As Long
hWnd = frm.hWnd
If frm.BorderStyle = FIXED_DOUBLE Then
frm.BackColor = COLOR_LIGHT_GRAY
lStyle = GetWindowLong(hWnd, GWL_STYLE)
lStyle = lStyle Or DS_MODALFRAME
lStyle = SetWindowLong(hWnd, GWL_STYLE, lStyle)
iResult = Ctl3dSubclassDlgEx(hWnd, &H0)
End If
End Sub
Sub Make3DDlg (dlgfrm As Form)
'Call this procedure in a form's Form_Load event to
'register the form as a 3D Dialog. This procedure calls
'the appropriate subprocedures in making the Dialog 3D
'Set the dlg forms attributes for CTL3D.
FormToDialog dlgfrm
'Now make the system menu for the form to
'show only Move and Close.
DlgSysMenu dlgfrm
End Sub
' Form Code:
' Enter the following code in the Form that be the last one
' to get unloaded. In the main program form for example.
' ** Another Important Note:
' When running in the design environment, be sure to end
' the app by using the Control Box - Close menu item or
' a command that calls the Form_Unload event for the form
' containing this code...
' ** Do Not End The App With VB's 'End' Command! **
' ** This Will Cause An AE or GPF!! **
' Add these 2 routines to the form:
Sub Activate3D ()
' This procedure registers your application to CTL3D.
Dim appInst%, suc%
' Get the application instance...
appInst% = GetWindowWord(Me.hWnd, GWW_HINSTANCE)
' Now register the application
suc% = Ctl3dRegister(appInst%)
' Did it register?
If suc% = 0 Then
MsgBox "The file CTL3D.DLL has not been found. Please insure that this
file is installed in your Windows\System directory.", 16, APPNAME
Exit Sub
End If
' Now subclass all of the dialog and message boxes for 3D
suc% = Ctl3dAutoSubclass(appInst%)
End Sub
Sub DeActivate3D ()
'Unregister CTL3D.
Dim appInst%, suc%
'Get the application instance again
appInst% = GetWindowWord(Me.hWnd, GWW_HINSTANCE)
'Unregister Ctl3d
suc% = Ctl3dUnregister(appInst%)
End Sub
Sub Form_Load ()
'Local Sub to register CTL3D
Activate3D
End Sub
Sub Form_Unload (Cancel As Integer)
'Local Sub to unregister CTL3D
DeActivate3D
End
End Sub
' Now, set the BorderStyle property to 3 - Fixed Double for
' the Form you wish to make 3D and a this code to that
' form's Form_Load event:
Sub Form_Load ()
' Register the form as a 3D Dialog.
Make3DDlg Me
End Sub
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to draw 3D offset bevels around controls.
'Note: This has only been tested with VB 3 and VB 4-16, if you convert
'this for use with other versions please let me know.-Burt Abreu
'-------------------------------------------------------------------
'Here's a routine for 3D offset bevels on controls.
Sub MakeIt3D (Ctrl As Control, nBevel%, nSpace%, bInset%)
'Makes the passed control appear 3D.
'Looks best when background of form or container is light gray.
'Parameters:
' Ctrl = apply 3D look to control name
' nBevel% = bevel width (pixels)
' nSpace% = surround distance from control (pixels)
' bInset% = True is 3D inset border
' False is 3D outset border
PixX% = Screen.TwipsPerPixelX
PixY% = Screen.TwipsPerPixelY
CTop% = Ctrl.Top - PixX%
CLft% = Ctrl.Left - PixY%
CRgt% = Ctrl.Left + Ctrl.Width
CBtm% = Ctrl.Top + Ctrl.Height
' Color used below:
' dark gray = &H808080
' white = &HFFFFFF
If bInset% Then 'recessed border
For i% = nSpace% To (nBevel% + nSpace% - 1)
AddX% = i% * PixX%
AddY% = i% * PixY%
Ctrl.Parent.Line (CLft% - AddX%, CTop% - AddY%)-(CRgt% + AddX%, CTop% - AddY%),
&H808080
Ctrl.Parent.Line (CLft% - AddX%, CTop% - AddY%)-(CLft% - AddX%, CBtm% + AddY%),
&H808080
Ctrl.Parent.Line (CLft% - AddX%, CBtm% + AddY%)-(CRgt% + AddX% + PixX%, CBtm% +
AddY%), &HFFFFFF
Ctrl.Parent.Line (CRgt% + AddX%, CTop% - AddY%)-(CRgt% + AddX%, CBtm% + AddY%),
&HFFFFFF
Next
Else 'raised border
For i% = nSpace% To (nBevel% + nSpace% - 1)
AddX% = i% * PixX%
AddY% = i% * PixY%
Ctrl.Parent.Line (CRgt% + AddX%, CBtm% + AddY%)-(CRgt% + AddX%, CTop% - AddY%),
&H808080
Ctrl.Parent.Line (CRgt% + AddX%, CBtm% + AddY%)-(CLft% - AddX%, CBtm% + AddY%),
&H808080
Ctrl.Parent.Line (CRgt% + AddX%, CTop% - AddY%)-(CLft% - AddX% - PixX%, CTop% -
AddY%), &HFFFFFF
Ctrl.Parent.Line (CLft% - AddX%, CBtm% + AddY%)-(CLft% - AddX%, CTop% - AddY%),
&HFFFFFF
Next
End If
End Sub
'Example:
'In the form's Paint event:
MakeIt3D Text1, 1, 0, True
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to draw 3D raised and recessed bevels on a form.
'How to fill a listbox with files, directories and drives.
'Note: This has only been tested with VB 3 & VB 4-16, if you convert
'this for use with other versions please let me know.-Burt Abreu
'-------------------------------------------------------------------
' Create A 3D Raised or Recessed Bevel On A Form
' Add the rountine below:
Sub FormBevelLines (FormFrame As Form, side, wid, color)
' This Sub is called by FormInner/Outer Bevel to draw the
' lines for FormInnerBevel and FormOuterBevel
Dim X1, Y1, X2, Y2 As Integer
Dim rightX, bottomY
Dim dx1, dx2, dy1, dy2 As Integer
Dim i
rightX = FormFrame.ScaleWidth - 1
bottomY = FormFrame.ScaleHeight - 1
Select Case side
Case 0 'Left side
X1 = 0: dx1 = 1
X2 = 0: dx2 = 1
Y1 = 0: dy1 = 1
Y2 = bottomY + 1: dy2 = -1
Case 1 'Right side
X1 = rightX: dx1 = -1
X2 = X1: dx2 = dx1
Y1 = 0: dy1 = 1
Y2 = bottomY + 1: dy2 = -1
Case 2 'Top side
X1 = 0: dx1 = 1
X2 = rightX: dx2 = -1
Y1 = 0: dy1 = 1
Y2 = 0: dy2 = 1
Case 3 'Bottom side
X1 = 1: dx1 = 1
X2 = rightX + 1: dx2 = -1
Y1 = bottomY: dy1 = -1
Y2 = Y1: dy2 = dy1
End Select
For i = 1 To wid
FormFrame.Line (X1, Y1)-(X2, Y2), color
X1 = X1 + dx1
X2 = X2 + dx2
Y1 = Y1 + dy1
Y2 = Y2 + dy2
Next i
End Sub
'Here are the 2 main routines:
Sub FormOuterBevel (FormFrame As Form, BevelWidth As Integer)
' This sub draws raised bevels on a Form
'
' Parameters Type Comments
' FormFrame Form the Form to bevel
' BevelWidth integer width of bevel in pixels
FormFrame.ScaleMode = 3 ' Pixels
FormBevelLines FormFrame, 0, BevelWidth, QBColor(15) 'White
FormBevelLines FormFrame, 1, BevelWidth, QBColor(8) 'D.Gray
FormBevelLines FormFrame, 2, BevelWidth, QBColor(15) 'White
FormBevelLines FormFrame, 3, BevelWidth, QBColor(8) 'D.Gray
End Sub
' Example:
' In the Form_Paint event:
FormOuterBevel Form1, 3 '3 pixels in width
Sub FormInnerBevel (FormFrame As Form, BevelWidth As Integer)
' This sub draws recessed bevels on a Form
'
' Parameters Type Comments
' FormFrame Form the Form to bevel
' BevelWidth integer width of bevel in pixels
'
FormFrame.ScaleMode = 3 ' Pixels
FormBevelLines FormFrame, 0, BevelWidth, QBColor(8) 'D.Gray
FormBevelLines FormFrame, 1, BevelWidth, QBColor(15) 'White
FormBevelLines FormFrame, 2, BevelWidth, QBColor(8)
FormBevelLines FormFrame, 3, BevelWidth, QBColor(15)
End Sub
' Example:
' Call from the Form_Paint event
FormInnerBevel Form1, 3 '3 pixels in width
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to draw a drop or back shadow on any control on a form.
'Note: This has only been tested with VB 3 & VB 4-16, if you convert
'this for use with other versions please let me know.-Burt Abreu
'-------------------------------------------------------------------
'Create A Back Or Drop Shadow On Controls
'Declare these constants in a .BAS module
' Label and Shape Styles
Global Const GFM_STANDARD = 0
Global Const GFM_RAISED = 1
Global Const GFM_SUNKEN = 2
' Control Shadow Styles
Global Const GFM_BACKSHADOW = 1
Global Const GFM_DROPSHADOW = 2
' Color constants
Global Const BOX_WHITE& = &HFFFFFF
Global Const BOX_LIGHTGRAY& = &HC0C0C0
Global Const BOX_DARKGRAY& = &H808080
Global Const BOX_BLACK& = &H0&
'Here is shadow routine:
Sub FormControlShadow (f As Form, C As Control, shadow_effect As Integer,
shadow_width As Integer, shadow_color As Long)
'This routine is used to create a Back or Drop shadow
'effect on any controls which are placed on a form.
'Simply place the control as normal and invoke the
'shadow with the code below.
'
' Parameters Type Comment
' f Form the form containing the control
' C Control the control to shadow
' shadow_effect integer GFM_DROPSHADOW or GFM_BACKSHADOW
' shadow_width integer width of the shadow in pixels
' shadow_color long color of the shadow
Dim shColor As Long
Dim shWidth As Integer
Dim oldWidth As Integer
Dim oldScale As Integer
shWidth = shadow_width
shColor = shadow_color
oldWidth = f.DrawWidth
oldScale = f.ScaleMode
f.ScaleMode = 3 'Pixels
f.DrawWidth = 1
Select Case shadow_effect
Case GFM_DROPSHADOW
f.Line (C.Left + shWidth, C.Top + shWidth)-Step(C.Width - 1, C.Height - 1),
shColor, BF
Case GFM_BACKSHADOW
f.Line (C.Left - shWidth, C.Top - shWidth)-Step(C.Width - 1, C.Height - 1),
shColor, BF
End Select
f.DrawWidth = oldWidth
f.ScaleMode = oldScale
End Sub
' Example:
' In the Form_Paint event:
FormControlShadow Me, Text1, GFM_DROPSHADOW, 2, QBColor(8)
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to create a 3D embossed effect on text using label controls.
'Note: This has only been tested with VB 3 & VB 4-16, if you convert
'this for use with other versions please let me know.-Burt Abreu
'-------------------------------------------------------------------
'Create an embossed effect on text using label controls.
'Declare these constants in a .BAS module
' Label and Shape Styles
Global Const GFM_STANDARD = 0
Global Const GFM_RAISED = 1
Global Const GFM_SUNKEN = 2
' Control Shadow Styles
Global Const GFM_BACKSHADOW = 1
Global Const GFM_DROPSHADOW = 2
' Color constants
Global Const BOX_WHITE& = &HFFFFFF
Global Const BOX_LIGHTGRAY& = &HC0C0C0
Global Const BOX_DARKGRAY& = &H808080
Global Const BOX_BLACK& = &H0&
'Here is the Embossed routine:
Static Sub FormLabelCaptionEmbossed (L1 As Label, L2 As Label, L3 As Label,
label_text As String, label_effect As Integer, label_forecolor As Long,
label_depth As Integer)
'Create an embossed effect using ordinary label controls
'on a form. Create 3 labels and place them on the form.
'The first label will be the "real" label.
'The second and third labels provide the embossed effect.
'Set all labels "BackStyle" property set to 0
'It's easiest to create a control array,
'and use Label1(0) as the real label,
'and Label1(1) and Label1(2) as the shadow labels.
' Parameters Type Comment
' L1 Label the "real" label
' L2 Label a shadow label
' L3 Label a shadow label
' label_text string if = "", the caption from L1 will be used
' label_effect integer GFM_RAISED or GFM_SUNKEN
' label_forecolor long color of top label
' label_depth integer offset depth for effect '1 is usually good
'
' *** For the best effect the forms backcolor should be set
' to Light Grey. ***
Dim lt As String
Dim savesm As Integer
Dim f As Form
Set f = L1.Parent
L1.Visible = False
L2.Visible = False
L3.Visible = False
savesm = f.ScaleMode
f.ScaleMode = 3 'pixels
If label_text = "" Then
lt = L1
Else
lt = label_text
End If
L1 = lt
L2 = lt
L3 = lt
L1.BackStyle = 0 'transparent
L1.ForeColor = label_forecolor
L2.Width = L1.Width
L2.Height = L1.Height
L2.BackStyle = L1.BackStyle
'Replaced this constant
L2.ForeColor = BOX_DARKGRAY&
L3.Width = L1.Width
L3.Height = L1.Height
L3.BackStyle = L1.BackStyle
'Replaced this constant
L3.ForeColor = BOX_WHITE&
Select Case label_effect
Case GFM_SUNKEN
L2.Left = L1.Left - label_depth
L2.Top = L1.Top - label_depth
L3.Left = L1.Left + label_depth
L3.Top = L1.Top + label_depth
Case GFM_RAISED
L2.Left = L1.Left + label_depth
L2.Top = L1.Top + label_depth
L3.Left = L1.Left - label_depth
L3.Top = L1.Top - label_depth
End Select
f.ScaleMode = savesm
L1.Visible = True
L2.Visible = True
L3.Visible = True
L1.ZOrder
End Sub
' Examples:
'Use existing text in label1(0)
FormLabelCaptionEmbossed label1(0), label1(1), label1(2), "", GFM_RAISED,
QBColor(7), 1
'Set label text in this function
FormLabelCaptionEmbossed label1(0), label1(1), label1(2), "My Label",
GFM_SUNKEN, QBColor(7), 1
|
