Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/CODIGO_1/3D_TABS/TABS.BAS

BASIC Source File | 1994-05-31 | 15.9 KB | 531 lines

Option Explicit

' used only by demo
Global tabsup%

'constants
Global Const SRCCOPY = &HCC0020
'flags for painting
Dim loading%, resizing%
'general purpose
Dim i%, r%

Type POINTAPI
    x As Integer
    y As Integer
End Type

Type RECT
    left As Integer
    top As Integer
    right As Integer
    bottom As Integer
End Type

Type boxsize
    width As Integer
    height As Integer
End Type

Type twipdata
    'scaling constants for each instance
    x As Integer            'twips/per/pixelx - depends on parent's scale mode
    y As Integer            'twips/per/pixely
    bx As Integer           'width of nonclient in twips
    by As Integer           'height of nonclient
End Type

'===========structure to hold the size data===========

Type TabData
    'control 'properties' - set by caller
    num As Integer          'num of Page()'s
    active As Integer       'active Page()
    orient As Integer       'up = 0, down = 1
    cols As Integer         'horz# of tabs
    left As Integer         'control left in twips
    top As Integer          'control top in twips
    offset As Integer       'tab angle
    'optional 'properties' - set by caller for sizable windows
    minwidth As Integer     'based on size of captions
    minheight As Integer    'user-defined
    width As Integer        'width of whole control
    height As Integer       'height of whole control
    'optional properties for 'nonaligned' controls
    insetx  As Integer
    insety As Integer
    'calculated by DefineControl()
    rows As Integer         '# of tabs horiz
    box As boxsize          'tabbox in pixels
    tab As boxsize          'invbox in pixels
    'twips or pixels,depending on scalemode of parent:
    twp As twipdata
End Type

Declare Function BitBlt% Lib "GDI" (ByVal hDestDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, ByVal YSrc%, ByVal dwRop&)
Declare Sub GetClientRect Lib "User" (ByVal hWnd%, lpRect As RECT)
Declare Function GetParent% Lib "User" (ByVal hWnd%)
Declare Sub GetWindowRect Lib "User" (ByVal hWnd%, lpRect As RECT)

Sub DefineControl (F As Form, tbox As Control, ibox As Control, page() As Control, tb As TabData)
Dim pageleft%, pagetop%, pageheight%, pagewidth%
Dim tabtop%, aligned%, w%, h%
Dim theight%, pheight%
'
loading = -1
'Debug.Print "=========new run================"
zGetScaleData F, tbox, tb

'note:if any of these values have been set by the caller, then
'the control will be sized to fit them all!
'otherwise the tab and the Form will be fitted to Page(0)
If tb.left = 0 And tb.top = 0 And tb.Width = 0 And tb.Height = 0 Then aligned = -1

'===initialize structure with size of the control======
    If tb.cols = 0 Then tb.cols = tb.num + 1
    If tb.num = 0 Then tb.num = UBound(page)
    If tb.offset = 0 Then tb.offset = 4
    If tb.insetx = 0 Then tb.insetx = 8 * tb.twp.x
    If tb.insety = 0 Then tb.insety = 8 * tb.twp.y
    '
    tb.rows = tb.num \ tb.cols + 1

'---set height of invbox & tabbox based on textsize
    tb.tab.Height = (tbox.TextHeight("X") + tb.offset)
    tb.box.Height = tb.tab.Height * tb.rows
    ' add 2 pixels to boxheight for 'focus' lines
    theight% = (tb.box.Height + 2) * tb.twp.x

'---set an integral pixel width for invbox & tabbox
    If aligned Then
    pagewidth = page(0).Width \ tb.twp.x
    tb.tab.Width = (pagewidth + (2 * tb.insetx \ tb.twp.x)) \ tb.cols
    tb.box.Width = tb.tab.Width * tb.cols
    tb.Width = tb.box.Width * tb.twp.x
    Else
    'for 'nonaligned', use tbox.width by default
    If tb.Width = 0 Then
        tb.tab.Width = (tbox.Width \ tb.cols) \ tb.twp.x
        tb.Width = tbox.Width
    Else
    'adjust the value set by the user
        tb.tab.Width = (tb.Width \ tb.cols) \ tb.twp.x
    End If
    tb.box.Width = tb.tab.Width * tb.cols
    pagewidth = tb.box.Width - 2 * tb.insetx \ tb.twp.x
    End If

'--- Calculate size of Page() height & inset---------------
    If aligned Then
    'use page(0) to set control and form height
    pageheight = page(0).Height \ tb.twp.y
    tb.insetx = (tb.Width - page(0).Width) \ 2
    pheight% = page(0).Height + 2 * tb.insety
    Else
    If tb.Height = 0 Then
        'if it wasn't specified, there's no way
        'to set it
        MsgBox "Must specify a control height: tb.Height = (some value)"
    Else
    pageheight = (tb.Height - theight%) \ tb.twp.y - 2 * tb.insety \ tb.twp.y
    'pheight% = pageheight * tb.twp.y + 2 * tb.insety
    pheight% = (tb.Height - theight)
       End If
    End If

'----height of entire control-----
    If aligned Then
    tb.Height = theight% + pheight%
    End If
'all fields show now be initialized (except minwidth)

'===position it all according to the align paramater=======
pageleft = tb.left + tb.insetx
If tb.orient Then 'tabs down
    pagetop = tb.top + tb.insety
    tabtop = tb.top + pheight%
Else ' tabs up
    pagetop = tb.top + tb.insety + theight%
    tabtop = tb.top
End If
'---size all the pages to fit Page(0)
For i = 0 To tb.num
    page(i).Move pageleft, pagetop, pagewidth * tb.twp.x, pageheight * tb.twp.y
Next
tbox.Move tb.left, tabtop, tb.Width, theight%

'----Draw the constant elements-----
DrawTabs ibox, tbox, tb
'----now resize the form
w = tb.Width + tb.twp.bx
h = tb.Height + tb.twp.by
If tb.twp.x = 1 Then
    w = w * screen.TwipsPerPixelX
    h = h * screen.TwipsPerPixelY
End If
If aligned Then
    F.Move F.Left, F.Top, tb.Width + tb.twp.bx, tb.Height + tb.twp.by
End If
page(tb.active).ZOrder
End Sub

Sub DrawTabs (ibox As Control, tbox As Control, tb As TabData)
Debug.Print "Entering DrawTabs------------"
'called by DefineControl
'called by TabResize for sizable windows
Dim n%                  'line color (shadow/hilite)
Dim box As RECT
Dim yoff%, xoff%        'inset for angled line
Dim top2%               'hilite/shadow line
Dim invert%             '+/- multiplier
Dim x%, y%, res%
Dim n1%, n2%

ibox.Cls
ibox.Move 0, 0, tb.tab.Width, tb.tab.Height
'set color and scale
box.left = 0: box.right = ibox.ScaleWidth - 1
xoff = 4
If tb.orient Then 'tabs down
    n = 8 'darkgrey
    'tbox.Scale (0, tbox.ScaleHeight - 1)-(tbox.ScaleWidth, -1)
    box.bottom = -1
    box.top = ibox.ScaleHeight - 1
    top2 = box.top - 1
    yoff = box.top - 4
    invert = -1
Else
    n = 15 'white
    box.top = 0: box.bottom = ibox.ScaleHeight
    top2 = 1
    yoff = 4
    invert = 1
End If

' Draw black lines
ibox.Line (box.left, yoff)-(xoff, box.top)                 'angle
ibox.Line -(box.right - xoff - 1, box.top)                'box.top
ibox.Line (box.right - xoff - 1, box.top)-(box.right, yoff + 1 * invert)  'angle
ibox.Line (box.right, box.top)-(box.right, box.bottom)                       'box.right
' Draw white/grey lines
ibox.Line (box.left, box.bottom)-(box.left, yoff + 1 * invert), QBColor(15)   'box.left
ibox.Line -(xoff, top2), QBColor(15)            'angle
ibox.Line -(box.right - xoff - 1, top2), QBColor(n)   'top
ibox.Line -(box.right - 1, yoff + 1 * invert), QBColor(8)      'angle
ibox.Line -(box.right - 1, box.bottom), QBColor(8)               'right
ibox.Line (box.left, box.top)-(box.left, yoff), QBColor(15)
ibox.Line (box.right, box.top)-(box.right, yoff)
ibox.Line (box.right - 1, box.top)-(box.right - 1, yoff), QBColor(8)

'blit to all the lower rows
tbox.Visible = 0
tbox.AutoRedraw = -1
If tb.rows > 1 Then
    If tb.orient Then
    n1 = 0: n2 = tb.rows - 2
    Else
    n1 = 1: n2 = tb.rows - 1
    End If
    For y = n1 To n2
    For x = 0 To tb.cols - 1
    If tb.orient Then
    res = BitBlt(tbox.hDC, x * tb.tab.Width, y * tb.tab.Height + 2, tb.tab.Width, tb.tab.Height + 2, ibox.hDC, 0, 0, SRCCOPY)
    Else
    res = BitBlt(tbox.hDC, x * tb.tab.Width, y * tb.tab.Height, tb.tab.Width, tb.tab.Height, ibox.hDC, 0, 0, SRCCOPY)
    End If
    Next: Next
End If

'add some grey for the background
ibox.Line (0, box.top)-(0, yoff), QBColor(8)
ibox.Line (1, box.top)-(1, yoff - 1 * invert), QBColor(8)
ibox.Line (2, box.top)-(2, yoff - 2 * invert), QBColor(8)
ibox.Line (box.right, box.top)-(box.right, yoff + 1 * invert), QBColor(8)
ibox.Line (box.right - 1, box.top)-(box.right - 1, yoff), QBColor(8)
ibox.Line (box.right - 2, box.top)-(box.right - 2, yoff - 1 * invert), QBColor(8)
ibox.Line (box.right - 3, box.top)-(box.right - 3, yoff - 2 * invert), QBColor(8)
ibox.PSet (3, box.top), QBColor(8)
ibox.PSet (box.right - 4, box.top), QBColor(8)
'now blit the top row
If tb.orient Then
    y = tb.rows - 1
Else
    y = 0
End If
For x = 0 To tb.cols - 1
    If tb.orient Then
    res = BitBlt(tbox.hDC, x * tb.tab.Width, y * tb.tab.Height + 2, tb.tab.Width, tb.tab.Height + 2, ibox.hDC, 0, 0, SRCCOPY)
    Else
    res = BitBlt(tbox.hDC, x * tb.tab.Width, y * tb.tab.Height, tb.tab.Width, tb.tab.Height, ibox.hDC, 0, 0, SRCCOPY)
    End If'blit
Next
tbox.Visible = -1
tbox.AutoRedraw = 0

End Sub

Sub DrawText (tbox As Control, page() As Control, tb As TabData)
'called by tbox_paint
'draws tab captions and focus line
Dim activerow%
Dim txtw%, y1%, y2%
Dim x%, y%, inner%, outer%, theight%, cell%
'
Debug.Print "Entering DrawText---------"
If resizing Then Debug.Print "aborting": Exit Sub
'
tbox.Cls

'get row containing active tab
'this row will be drawn on bottom
'values : 0,1,2....
activerow = tb.active \ tb.cols
'get first tab in active row
cell = activerow * tb.cols
'set y pos
If tb.orient Then  'tabsdown
    inner = 0
    outer = (tb.rows - 1) * tb.tab.Height
    theight = tb.tab.Height
Else                'tabsup
    inner = tb.box.Height - tb.tab.Height
    outer = 0
    theight = -tb.tab.Height
End If
'set x pos

For y = inner To outer Step theight%
For x = 0 To (tb.cols - 1) * tb.tab.Width Step tb.tab.Width
    '
    If cell > tb.num Then
    'blank tabs
    cell = 0:
    If x <> 0 Then Exit For
    End If
    If cell = tb.active Then tbox.FontBold = -1 Else tbox.FontBold = 0
    txtw = tbox.TextWidth(page(cell).Tag)
    'do something here if the caption is too large
    'if txtw >tb.tab.width then
    'end if
    tbox.CurrentX = x + (tb.tab.Width - txtw) \ 2
    tbox.CurrentY = y + tb.offset \ 2
    tbox.Print page(cell).Tag
    cell = cell + 1
    'If n > tb.num Then n = 0
Next
Next

' draw a blank line underneath the selected tab
If tb.orient Then
    inner = 8
    y2 = 0: y1 = 1
Else
    inner = 15
    y1 = tbox.ScaleHeight - 1: y2 = tbox.ScaleHeight - 2
End If
'solid line
tbox.Line (0, y1)-(tbox.ScaleWidth, y1), QBColor(inner)
tbox.Line (0, y2)-(tbox.ScaleWidth, y2)
'focus line
x = (tb.active Mod tb.cols) * tb.tab.Width
tbox.Line (x + 1, y1)-(x + tb.tab.Width - 2, y1), tbox.BackColor
tbox.Line (x + 1, y2)-(x + tb.tab.Width - 1, y2), tbox.BackColor
tbox.PSet (x, y1), QBColor(15)
tbox.PSet (x, y2), QBColor(15)
tbox.ZOrder 0
End Sub

Sub NextPage (tbox As Control, page() As Control, tb As TabData)
Dim n%
n% = ((tb.active + 1) Mod (tb.num + 1))
tb.active = n
page(n).ZOrder
DrawText tbox, page(), tb
End Sub

Sub PrevPage (tbox As Control, page() As Control, tb As TabData)
Dim n%
If tb.active = 0 Then n = tb.num Else n = tb.active - 1
tb.active = n
page(n).ZOrder
DrawText tbox, page(), tb
End Sub

Sub TabClick (Button%, x As Single, y As Single, tbox As Control, page() As Control, tb As TabData)
'called by tbox_MouseUp
Dim hpos%, vpos%
Dim activerow%, thisrow%, row%, n%

activerow = tb.active \ tb.cols '0,1,2...
'
hpos = x \ tb.tab.Width  '=0,1,2...
vpos = y \ tb.tab.Height
If tb.orient = 0 Then
    vpos = tb.rows - vpos - 1
End If
'
vpos = vpos + activerow
If vpos >= tb.rows Then
    vpos = vpos - (tb.rows)
End If
n = (vpos * tb.cols) + hpos

'blank tabs:
If n < 0 Or n > tb.num Then Exit Sub

tb.active = n
page(n).ZOrder
DrawText tbox, page(), tb

End Sub

Sub TabResize (F As Form, x%, y%, tbox As Control, ibox As Control, page() As Control, tb As TabData)
'called by form_resize for resizable windows
Dim tw%             'tabwidth
Dim l%, t%, w%, h%
Dim mintabwidth%, minwinheight%
Static here%, tightening%
Dim theight%, pheight%
Dim win As RECT, client As RECT
'---ignore resize events during form_load-------
If loading Then
    here = here + 1: If here < 2 Then Exit Sub
    If here = 2 Then here = 0: loading = 0: Exit Sub
End If
'---exit if resize was triggered by this routine
If tightening% Then Exit Sub

resizing = -1: Debug.Print "Entering TabResize----------"

'get width needed to display text
'note: this can be declared static if calculated only
'the first time if tab captions do not change:
'if mintabwidth = 0 then
mintabwidth = zGetMaxTextWidth(tbox, page(), tb)
'end if
tw = mintabwidth * tb.cols

'if the caller set minwidth then use it
If tb.minwidth <> 0 Then
    If tb.minwidth \ tb.twp.x > tw Then
    tw = tb.minwidth \ tb.twp.x
    mintabwidth = tw \ tb.cols
    End If
End If

'get a minheight
minwinheight = tb.tab.Height + 20 'some arbitrary size
If tb.minheight <> 0 Then
    If tb.minheight \ tb.twp.y > minwinheight Then
    minwinheight = tb.minheight \ tb.twp.y
    End If
End If
'
GetClientRect F.hWnd, client
'---set an integral width for the control
    If client.right < tw Then
    tb.tab.Width = mintabwidth
    Else
    tb.tab.Width = client.right \ tb.cols
    End If
    tb.box.Width = tb.tab.Width * tb.cols
    'reset the form size
    tb.Width = tb.box.Width * tb.twp.x
'---check the new height
    If client.bottom < minwinheight Then
    tb.Height = minwinheight * tb.twp.y
    Else
    tb.Height = client.bottom * tb.twp.y
    End If
    theight% = tb.box.Height * tb.twp.x
    pheight = tb.Height - theight%

'------ready to draw------------------:
tbox.Visible = 0
For i = 0 To tb.num: page(i).Visible = 0: Next

'---fit the tbox to the window
l = tb.insetx
w = tb.Width - 2 * tb.insetx
h = pheight - 2 * tb.insety
'
If tb.orient Then 'tabs down
    t = tb.top + l
    tbox.Move 0, tb.top + pheight, tb.Width, theight
Else ' tabs up
    t = tb.top + theight + l
    tbox.Move tb.left, tb.top, tb.Width, theight
End If
' fit the pages to the window
For i = 0 To tb.num: page(i).Move l, t, w, h: Next
'
'this triggers more calls to this routine:
If F.WindowState = 0 Then
    tightening = -1
    'adjust window to integral tabwidth
    F.Move F.Left, F.Top, tb.Width + tb.twp.bx, tb.Height + tb.twp.by
    'this isn't the proper way to do this!
    'need to find if the menu will wrap and make this
    'adjustment before the above line
    'adjust for wrapped menu items:
    GetWindowRect F.hWnd, win
    GetClientRect F.hWnd, client
   If (win.bottom - win.top - client.bottom) * tb.twp.y <> tb.twp.by Then
    tb.twp.by = (win.bottom - win.top - client.bottom) * tb.twp.y
    F.Move F.Left, F.Top, tb.Width + tb.twp.bx, tb.Height + tb.twp.by
   End If
End If
'
DrawTabs ibox, tbox, tb
'
tightening = 0: resizing = 0
DrawText tbox, page(), tb
'
'finished, show it
tbox.Visible = -1
For i = 0 To tb.num: page(i).Visible = -1: Next
'
End Sub

Private Function zGetMaxTextWidth% (tbox As Control, page() As Control, tb As TabData)
'called by TabResize
Dim i%, w%, max%
For i = 0 To tb.num
w = tbox.TextWidth(page(i).Tag)
If w > max Then max = w
Next
zGetMaxTextWidth = max + 2 * tb.offset
End Function

Private Sub zGetScaleData (F As Form, tbox As Control, tb As TabData)
'called by DefineControl
Dim containerhwnd%
Dim win As RECT, client As RECT
'adjustment for scalemode of the form
tb.twp.x = screen.TwipsPerPixelX
tb.twp.y = screen.TwipsPerPixelY
'
containerhwnd% = GetParent(tbox.hWnd)
If containerhwnd% = F.hWnd Then
    If F.ScaleMode = 3 Then tb.twp.x = 1: tb.twp.y = 1
Else
For i = 0 To F.Controls.Count - 1
    On Error Resume Next
    If F.Controls(i).hWnd = containerhwnd Then
    If F.Controls(i).ScaleMode = 3 Then
        If Err Then Exit For
        tb.twp.x = 1: tb.twp.y = 1
    End If
    Exit For
    End If
Next
End If

'subtract client area from window for border sizes
GetWindowRect F.hWnd, win
GetClientRect F.hWnd, client
tb.twp.bx = (win.right - win.left - client.right) * tb.twp.x
tb.twp.by = (win.bottom - win.top - client.bottom) * tb.twp.y
End Sub