Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/dialog/demo3d/module1.bas

BASIC Source File | 1995-03-25 | 13.9 KB | 400 lines

Option Explicit

'Compiled by:  M. John Rodriguez,  CIS ID: 100321,620
'                             Internet ID: [e-mail]
'                                        : [e-mail]
'
'Please feel free to distribute this for your use and experiments.  Please ensure
'that you give credit to the folks who unknowingly helped to do this.
'
'
'This procedures contained in this module are the culmination of work supplied by various
'individuals.  It would not be proper for me not to include their names.  To make it easier
'to tell who authored what, their names are commented in the appropriate procedures.
'
' Module contains:
' App3DRegister     - call this when you first begin your application
' App3DUnregister   - call this just before you exit.
' ComboBoxIn3D      - for combo boxes, called by FormIn3D
' ControlIn3D       - for most controls, called by FormIn3D
' Dlg3DRegister     - call this when you load your dialog form
' Dlg3DUnregister   - call this when you unload the dialog form
' DlgIn3D           - call this to set your dialog window attributes for CTL3D
' DlgSysMenu        - removes the last entries in the system menu.  Make sure that
'                     you set the MinButton and MaxButton properties to false so
'                     you wont have to look at the Restore, Minimize, and Maximize entries
'                     just shows the Move and Close menu items
' ExitProgram       - Performs the cleanup for the application.. nothing exciting...
' FormIn3D          - adds 3D appearance to VB's controls - does not use CTL3D
' LineIn3D          - for graphic lines, called by FormIn3D
' Main              - demonstrates that you don't need to start off with a form to use CTL3D
'
'
'
'CTL3D API calls... If you don't have CTL3DV2.DLL, you can delete the V2 and it should
'still work properly.
Declare Function Ctl3dAutoSubclass Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dRegister Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dUnregister Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dSubclassDlgEx Lib "Ctl3DV2.DLL" (ByVal hWnd As Integer, dFlags As Long) As Integer


'Other API Calls for the Forms...
Declare Function GetModuleHandle Lib "Kernel" (ByVal ModuleName As String) As Integer
Declare Function GetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Long
Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
Declare Function SetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long

Global Const BUTTON_FACE = &H8000000F
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 API's for adjusting the 3D Dialog box system menu...
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

'Some colors for us to use...
Global Const COLOR_BLACK = &H0&
Global Const COLOR_LIGHT_GRAY = &HC0C0C0
Global Const COLOR_DARK_GRAY = &H808080
Global Const COLOR_WHITE = &HFFFFFF

'/* Ctl3d Control ID */
Global Const CTL3D_BUTTON_CTL = 0
Global Const CTL3D_LISTBOX_CTL = 1
Global Const CTL3D_EDIT_CTL = 2
Global Const CTL3D_COMBO_CTL = 3
Global Const CTL3D_STATIC_CTL = 4

'This is for the application itself.  You need for your whole application.
'Otherwise, you won't get 3D Message Boxes and common dialogs.
'
Sub App3DRegister ()

Dim appInst%, suc%, appname$

appname$ = App.EXEName

'Get the application instance...
appInst% = GetModuleHandle(appname$)
'Now register the application
suc% = Ctl3dRegister(appInst%)
'now subclass all of the dialog and message boxes
suc% = Ctl3dAutoSubclass(appInst%)

End Sub

'Before you exit your application, give this procedure a call..
'In this case, I have a procedure called ExitProgram() that allows
'me to do all of my cleanup functions.  This procedure is in there.
'
Sub App3DUnregister ()

'Call this just before your application exits..

Dim appInst%, suc%, appname$

appname$ = App.EXEName

'Get the application instance again..
appInst% = GetModuleHandle(appname$)

'Now unregister us...
suc% = Ctl3dUnregister(appInst%)

End Sub

Sub CenterForm (f As Form)

Dim iTop As Integer, iLeft As Integer

'Make sure we are normal..
If f.WindowState <> 0 Then Exit Sub

'Get the top and left coordinates for the form to be in the center
iTop = (Screen.Height - f.Height) \ 2
iLeft = (Screen.Width - f.Width) \ 2

'Now move us there..
f.Move iLeft, iTop

End Sub

'
' ControlIn3D paints a 3D-border around the control given in ctrlTarget.
' nBevel controls the the deepness, nSpace the distance between the control
' and the 3D-border and bInset sets the border to be drawn inset or outset.
'
' Parts of this code are taken from the VB Tips & Tricks help file.
' Original code written by Matej Nastran.
'
'
Sub ComboBoxIn3D (ctrlCombo As Control, nBevel As Integer)

    Dim PixelX As Integer, PixelY As Integer
    Dim CTop As Integer, CRight As Integer, CBottom As Integer

    ' Just put "No 3D" in the Tag property and your ComboBox keeps 2D
    If InStr(UCase(ctrlCombo.Tag), "NO 3D") = 0 Then

    ControlIn3D ctrlCombo, nBevel, 0, True

    If ctrlCombo.Style = 0 Then             'Remove white space only
        PixelX = Screen.TwipsPerPixelX      'if it is a Dropdown ComboBox
        PixelY = Screen.TwipsPerPixelY
        CTop = ctrlCombo.Top
        CRight = ctrlCombo.Left + ctrlCombo.Width
        CBottom = ctrlCombo.Top + ctrlCombo.Height
        ctrlCombo.Parent.Line (CRight - PixelX * 24, CTop)-(CRight - PixelX * 18, CBottom - PixelY), COLOR_LIGHT_GRAY, BF
    End If
    End If

End Sub

'
'
' ControlIn3D paints a 3D-border around the control given in ctrlTarget.
' nBevel controls the the deepness, nSpace the distance between the control
' and the 3D-border and bInset sets the border to be drawn inset or outset.
'
' Parts of this code are taken from the VB Tips & Tricks help file.
' Original code written by Matej Nastran.
'
Sub ControlIn3D (ctrlTarget As Control, nBevel As Integer, nSpace As Integer, bInset As Integer)
    Dim CTop As Integer, CLeft As Integer, CRight As Integer, CBottom As Integer
    Dim PixelX As Integer, PixelY As Integer, AddX As Integer, AddY As Integer
    Dim i As Integer

    ' Just put "No 3D" in the Tag property and your control keeps 2D
    If InStr(UCase(ctrlTarget.Tag), "NO 3D") = 0 Then
    PixelX = Screen.TwipsPerPixelX
    PixelY = Screen.TwipsPerPixelY
    CTop = ctrlTarget.Top - PixelY
    CLeft = ctrlTarget.Left - PixelX
    CRight = ctrlTarget.Left + ctrlTarget.Width
    CBottom = ctrlTarget.Top + ctrlTarget.Height
    If bInset Then          ' Draw border inset
        For i = nSpace To (nBevel + nSpace - 1)
        AddX = i * PixelX: AddY = i * PixelY
        ctrlTarget.Parent.Line (CLeft - AddX, CTop - AddY)-(CRight + AddX, CTop - AddY), COLOR_DARK_GRAY
        ctrlTarget.Parent.Line (CLeft - AddX, CTop - AddY)-(CLeft - AddX, CBottom + AddY), COLOR_DARK_GRAY
        ctrlTarget.Parent.Line (CLeft - AddX, CBottom + AddY)-(CRight + AddX + PixelX, CBottom + AddY), COLOR_WHITE
        ctrlTarget.Parent.Line (CRight + AddX, CTop - AddY)-(CRight + AddX, CBottom + AddY), COLOR_WHITE
        Next i
    Else                    ' Draw border outset
        For i = nSpace To (nBevel + nSpace - 1)
        AddX = i * PixelX: AddY = i * PixelY
        ctrlTarget.Parent.Line (CRight + AddX, CBottom + AddY)-(CRight + AddX, CTop - AddY), COLOR_DARK_GRAY
        ctrlTarget.Parent.Line (CRight + AddX, CBottom + AddY)-(CLeft - AddX, CBottom + AddY), COLOR_DARK_GRAY
        ctrlTarget.Parent.Line (CRight + AddX, CTop - AddY)-(CLeft - AddX - PixelX, CTop - AddY), COLOR_WHITE
        ctrlTarget.Parent.Line (CLeft - AddX, CBottom + AddY)-(CLeft - AddX, CTop - AddY), COLOR_WHITE
        Next i
    End If
    End If

End Sub

'Call this procedure for each form.  This is my add on to the the other code
'presented.  I had a hard time with this but I was able to deduce two important
'facts.
'1)  VB Forms in by themselves are independent entities of each other in the
'VB environment.  That means for each form to work, you have to at a minimum
'register it with CTL3D.
'
'2) Once you Initialize your Autosubclass for the app, you don't have to do it with
'each dlg because the main application has already done it.  Solves the
'global application problem of having 3D Dialogs and Message Boxes and eliminates a GPF if
'you try to autosubclass once you already have done it.
'
Sub Dlg3DRegister (fm As Form)

Dim dlgInst%, suc%

'Get the forms instance for this case
dlgInst% = GetWindowWord(fm.hWnd, GWW_HINSTANCE)

'Register the dialog
suc% = Ctl3dRegister(dlgInst%)


End Sub

' Once you finish with the dialog, call this procedure in the form_unload
' event to deregister the dialog box.
'
Sub Dlg3DUnregister (fm As Form)

Dim dlghInst%, suc%

'Get the instance of the dialog
dlghInst% = GetWindowWord(fm.hWnd, GWW_HINSTANCE)

'Unregister it..
suc% = Ctl3dUnregister(dlghInst%)


End Sub

'This procedure makes my dialog box appear 3D.
'
'This snippet of code was taken by a submission from
'RANDRIAMBOLOLONA Roland H. - Compuserve ID - 100331,2516
'
'He says he got some of it from the MARCH '95 VBPJ  Code Listing - TIPS.TXT
'
'This procedure was not commented, I am just telling you where I got the source
'for this because it works very well...
'
Sub DlgIn3D (frm As Form)

    Dim hWnd As Integer
    Dim iResult As Integer
    Dim lStyle As Long

    hWnd = frm.hWnd
    If frm.BorderStyle = FIXED_DOUBLE Then
    frm.BackColor = BUTTON_FACE
    lStyle = GetWindowLong(hWnd, GWL_STYLE)
    lStyle = lStyle Or DS_MODALFRAME
    lStyle = SetWindowLong(hWnd, GWL_STYLE, lStyle)
    iResult = Ctl3dSubclassDlgEx(hWnd, &H0)
    End If

End Sub

'This procedure modifies the menu for the dialog box.
'In order for this to work correctly, the form must have the MinButton and MaxButton set
'to false if you leave the ControlBox property set to true.  Otherwise, Restore, Maximize, and
'Minimize will stay on...
'
'This snippet of code was taken by a submission from
'RANDRIAMBOLOLONA Roland H. - Compuserve ID - 100331,2516
'
'He says he got some of it from the MARCH '95 VBPJ  Code Listing - TIPS.TXT
'
'The author did not say if he did this, I am passing the accolades - with a few
'modifications for readability
'
Sub DlgSysMenu (fm As Form)

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 ExitProgram ()

App3DUnregister

End


End Sub

'
' FormIn3D paints a 3D-border around controls on the given Form frmTarget.
' nBevel controls the the deepness of the 3D-border. bBlaster parameter removed,
' don't need it in this case.
'
' Controls that are affected:
'       TextBox         ListBox         ComboBox
'       DriveListBox    DirListBox      FileListBox
'       Line
'       ... (list can be easly expanded)
'
' Just put "No 3D" in the Tag property of a specific control or the form
' itself and it is not painted in 3D.
'
' Call this function from your forms Paint-event.
'
' Parts of this code are taken from the VB Tips & Tricks help file.
' Original code written by Matej Nastran.
'
Sub FormIn3D (frmTarget As Form, nBevel As Integer)
    Dim DrawWidthOld As Integer, ScaleModeOld As Integer
    Dim i As Integer, Ret As Integer
    Dim ctrlTarget As Control
    Static bBusy As Integer


    If bBusy Then Exit Sub          'Got some DoEvents. Just in case...
    bBusy = True

    DrawWidthOld = frmTarget.DrawWidth
    frmTarget.DrawWidth = 1
    ScaleModeOld = frmTarget.ScaleMode
    frmTarget.ScaleMode = 1     'Twips

    DoEvents

    'Loop controls
    For i = 0 To (frmTarget.Controls.Count - 1)
    Set ctrlTarget = frmTarget.Controls(i)
    If TypeOf ctrlTarget Is TextBox Then ControlIn3D ctrlTarget, nBevel, 0, True
    If TypeOf ctrlTarget Is ListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
    If TypeOf ctrlTarget Is ComboBox Then   'ComboBoxes are special
        ComboBoxIn3D ctrlTarget, nBevel
    End If
    If TypeOf ctrlTarget Is DriveListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
    If TypeOf ctrlTarget Is DirListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
    If TypeOf ctrlTarget Is FileListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
    If TypeOf ctrlTarget Is Line Then       'Lines are also special
        LineIn3D ctrlTarget
    End If
    If TypeOf ctrlTarget Is Label Then ControlIn3D ctrlTarget, nBevel, 0, True
    Next i

    frmTarget.DrawWidth = DrawWidthOld      'Always restore what you change
    frmTarget.ScaleMode = ScaleModeOld


    bBusy = False

End Sub

'
' LineIn3D paints the given Line-control ctrlLine in 3D.
' frmTarget is the Form containing that Line.
'
Sub LineIn3D (ctrlLine As Control)

    If InStr(UCase(ctrlLine.Tag), "NO 3D") = 0 Then
    ctrlLine.BorderColor = COLOR_DARK_GRAY
    'Check if line is vertical or horizontal
    If Abs(ctrlLine.X2 - ctrlLine.X1) > Abs(ctrlLine.Y2 - ctrlLine.Y1) Then
    ctrlLine.Parent.Line (ctrlLine.X1, ctrlLine.Y1 + Screen.TwipsPerPixelY)-(ctrlLine.X2, ctrlLine.Y2 + Screen.TwipsPerPixelY), COLOR_WHITE
    Else
    ctrlLine.Parent.Line (ctrlLine.X1 + Screen.TwipsPerPixelX, ctrlLine.Y1)-(ctrlLine.X2 + Screen.TwipsPerPixelX, ctrlLine.Y2), COLOR_WHITE
    End If
    End If

End Sub

Sub Main ()

'First things first, register my application...
App3DRegister


'Now show the first form...
Form1.Show



End Sub