home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
vb_code1
/
3d_tabs
/
tabs.bas
< prev
next >
Wrap
BASIC Source File
|
1994-05-31
|
16KB
|
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