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.
'------------------------------------------------------------------- '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