home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
vb_code1
/
folder
/
folders.bas
next >
Wrap
BASIC Source File
|
1994-05-29
|
11KB
|
379 lines
Option Explicit
Const TabOffsetConstant = 4
Dim Folders() As Control ' Array of the form's folders
Global FolderNum As Integer ' Current active folder
Global NumFolders As Integer ' Total number of folders
Dim VisibleTabs As Integer ' Number of tabs across screen
Dim OneTabHeight As Integer ' Height of one row of tabs
Dim FolderTabs As Control ' Picture to paint tabs on
Dim TabWidth As Long ' Tab width
Dim NumRows As Integer ' Number of rows of tabs
Dim TabOffset As Integer ' # of pixels for tab's diagonal
Dim TabOffsetX As Integer ' Offset translated to x-twips
Dim TabOffsetY As Integer ' Offset translated to y-twips
'Used for border/menu sizes
Declare Function GetSystemMetrics% Lib "User" (ByVal nIndex%)
'Used to see if menu is used
Declare Function GetMenu Lib "User" (ByVal hWnd%) As Integer
' Locate the folder controls
' Set the Folders array to point to the folders
' Modify each folder to match the first folder (index=0)
Function DefineFolders (NumAcross As Integer, Fldr As Control, FolderTabControl As Control) As Integer
Dim I As Integer
' Find out how many folders in an array are on the form
' Done by checking each control to see if it is a folder
' and then checking each folder to see if it has an index
' value (part of an array of folders)
NumFolders = 0
On Error GoTo NoIndex
For I = 0 To Fldr.Parent.Controls.Count - 1
If TypeOf Fldr.Parent.Controls(I) Is Frame Then
If Not Fldr.Parent.Controls(I).Index >= 0 Then
' Fill Space
Else
If Fldr.Parent.Controls(I).Index > NumFolders Then NumFolders = Fldr.Parent.Controls(I).Index
End If
End If
Next I
On Error GoTo 0
' Fill the Folders array with pointers to the folder
' on the form
' Done by the same loop as last time, but this time
' I assign it to an array
ReDim Folders(NumFolders)
On Error GoTo NoIndex
For I = 0 To Fldr.Parent.Controls.Count - 1
If TypeOf Fldr.Parent.Controls(I) Is Frame Then
If Not Fldr.Parent.Controls(I).Index >= 0 Then
'Fill Space
Else
On Error GoTo 0
Set Folders(Fldr.Parent.Controls(I).Index) = Fldr.Parent.Controls(I)
On Error GoTo NoIndex
End If
End If
Next I
On Error GoTo 0
' Define Standard variables
If NumAcross = 0 Then
VisibleTabs = NumFolders + 1
Else
VisibleTabs = NumAcross
End If
TabOffset = TabOffsetConstant
SetTabOffset -TabOffset
'Modify all the folders to match folder0
For I = 0 To NumFolders
Folders(I).Top = Folders(0).Top
Folders(I).Left = Folders(0).Left
Folders(I).Width = Folders(0).Width
Folders(I).Height = Folders(0).Height
Folders(I).BackColor = Folders(0).BackColor
Folders(I).Tag = Folders(I).Caption
Folders(I).FontBold = False
Folders(I).FontItalic = Folders(0).FontItalic
Folders(I).FontName = Folders(0).FontName
Folders(I).FontSize = Folders(0).FontSize
Folders(I).FontStrikethru = Folders(0).FontStrikethru
Folders(I).FontUnderline = Folders(0).FontUnderline
Folders(I).ForeColor = Folders(0).ForeColor
Folders(I).Visible = True
Folders(I).ZOrder 1
Next I
FolderNum = 0 ' Start with the first folder highlighted
' If you want a different first folder, use
' the GotoFolder function right after you
' use DefineFolders
'Fldr.Parent.Show
DefineTabs FolderTabControl ' Configure the tab picture box
Call ShowFolder ' Move the first folder to the top
Exit Function
NoIndex:
Resume Next
End Function
' Initialize the picture box that the
' folder tabs are drawn in
Private Sub DefineTabs (FolderTabControl As Control)
' Calculate the number of rows needed to display all tabs
NumRows = NumFolders \ VisibleTabs + 1
' Set the picture box's properties
Set FolderTabs = FolderTabControl
FolderTabs.AutoSize = False
FolderTabs.ScaleMode = 1
FolderTabs.Left = Folders(0).Left
FolderTabs.Width = Folders(0).Width
TabWidth = (FolderTabs.Width \ VisibleTabs)
FolderTabs.AutoRedraw = True
FolderTabs.BackColor = Folders(0).BackColor
FolderTabs.BorderStyle = 0
FolderTabs.DragMode = 0
FolderTabs.Enabled = True
FolderTabs.FillStyle = 0
FolderTabs.DrawStyle = 0
FolderTabs.FontBold = Folders(0).FontBold
FolderTabs.FontBold = Folders(0).FontBold
FolderTabs.FontItalic = Folders(0).FontItalic
FolderTabs.FontName = Folders(0).FontName
FolderTabs.FontSize = Folders(0).FontSize
FolderTabs.FontStrikethru = Folders(0).FontStrikethru
FolderTabs.FontUnderline = Folders(0).FontUnderline
FolderTabs.ForeColor = Folders(0).ForeColor
FolderTabs.LinkMode = 0
FolderTabs.MousePointer = 0
FolderTabs.TabStop = False
FolderTabs.Visible = True
FolderTabs.ZOrder 0
' Calculate the tab height based on the height of a sample
' letter + the offset height
OneTabHeight = (FolderTabs.TextHeight("X") + TabOffsetY)
FolderTabs.Height = OneTabHeight * NumRows
FolderTabs.Top = Folders(0).Top - FolderTabs.Height + OneTabHeight
End Sub
' Draws a single folder tab
' TabNumber = the tab that is being drawn
' HorPos = the tabs horizontal position on the folders
' VerPos = the row the tab is on
' Foreground = True if it is the currently selected tab
Private Sub DrawTab (TabNumber As Integer, HorPos As Integer, VerPos As Integer, ForeGround As Integer)
Dim TabTextWidth As Long
Dim L%, R%, T%, B%
' Set the Top/Bottom/Left/Right values of the single tab
T = FolderTabs.Height - VerPos * OneTabHeight
B = T + OneTabHeight - TwipsY(1)
L = TabWidth * HorPos
R = L + TabWidth - TwipsX(1)
' Draw the lines around the tab
FolderTabs.Line (L, B)-(L, T + TabOffsetY), 0
' If you reverse the comments in the next three lines, you will
' get a rounded top-left corner (not very noticable)
'FolderTabs.Circle Step(TabOffsetX, 0), TabOffsetX, 0, 3.141 / 2, 3.141
'FolderTabs.CurrentY = T
FolderTabs.Line -(L + TabOffsetX, T), 0
FolderTabs.Line -(R - TabOffsetX, T), 0
' If you reverse the comments in the next three lines, you will
' get a rounded top-right corner (not very noticable)
'FolderTabs.Circle Step(0, TabOffsetY), TabOffsetX, 0, 0, 3.141 / 2
'FolderTabs.CurrentX = R
FolderTabs.Line -(R, T + TabOffsetY), 0
FolderTabs.Line -(R, B), 0
' If it is the selected folder, draw a blank line underneath
If ForeGround Then FolderTabs.Line -(L, B), FolderTabs.BackColor
' Print the tab's title (bold if foreground)
FolderTabs.FontBold = ForeGround
TabTextWidth = FolderTabs.TextWidth(Folders(TabNumber).Caption)
FolderTabs.CurrentX = (TabWidth * HorPos) + (TabWidth \ 2) - (TabTextWidth \ 2)
FolderTabs.CurrentY = T + (TabOffsetY \ 2)
FolderTabs.Print Folders(TabNumber).Caption
FolderTabs.FontBold = False
End Sub
' Draws each of the visible tabs on screen
Private Sub DrawTabs ()
Dim I As Integer
FolderTabs.Cls
' Draws the lines below the tabs first
For I = 1 To NumRows
FolderTabs.Line (0, I * OneTabHeight - TwipsY(1))-(FolderTabs.Width, I * OneTabHeight - TwipsY(1)), 0
Next I
' Draw each tab
For I = 0 To NumFolders
DrawTab I, HorTabPos(I), VerTabPos(I), I = FolderNum
Next I
' Draw lines down the left and right side
FolderTabs.Line (0, TabOffsetY)-(0, FolderTabs.Height - TwipsY(1)), 0
FolderTabs.Line (FolderTabs.Width - TwipsX(1), FolderTabs.Height - TwipsY(1))-(FolderTabs.Width - TwipsX(1), OneTabHeight - TwipsY(1)), 0
End Sub
' Jump to the folder tab that was clicked on
' This is called by the Tab picture box's MouseDown procedure
Sub FolderClick (Button As Integer, X As Single, Y As Single)
Dim HorPos As Integer
Dim VerPos As Integer
HorPos = X \ (FolderTabs.Width \ VisibleTabs)
VerPos = NumRows - (Y \ (FolderTabs.Height \ NumRows)) - 1
VerPos = (VerPos + (FolderNum \ VisibleTabs + 1)) Mod NumRows - 1
If VerPos = -1 Then VerPos = NumRows - 1
GotoFolder (VerPos * VisibleTabs) + HorPos
End Sub
' Make FolderNumber the active folder
Sub GotoFolder (FolderNumber As Integer)
If (FolderNumber >= 0) And (FolderNumber <= NumFolders) Then FolderNum = FolderNumber
ShowFolder
End Sub
' Calculate the column of a particular tab
Private Function HorTabPos (TN As Integer) As Integer
HorTabPos = TN Mod VisibleTabs
End Function
' Moves to the next folder
Sub NextFolder ()
FolderNum = ((FolderNum + 1) Mod (NumFolders + 1))
ShowFolder
End Sub
' Move to the previous folder
Sub PrevFolder ()
If FolderNum = 0 Then
FolderNum = NumFolders
Else
FolderNum = FolderNum - 1
End If
ShowFolder
End Sub
' Calculates the Twips ratio of TabOffset
Private Sub SetTabOffset (Offset As Integer)
TabOffset = Abs(Offset)
TabOffsetX = TwipsX(CLng(TabOffset))
TabOffsetY = TwipsY(CLng(TabOffset))
If Offset >= 0 Then DrawTabs
End Sub
' Makes the current folder visible
' Then updates the tabs
Private Sub ShowFolder ()
Dim I As Integer
For I = 0 To NumFolders
Folders(I).Visible = (I = FolderNum)
Next I
Call DrawTabs
End Sub
' Moves the whole tab thingy to the top left corner of the
' form, and then shrinks the form to fit perfectly.
Sub TightenForm ()
Dim SB As Long
Dim CH As Integer
Dim MH As Integer
Dim OY As Long, OX As Long
FolderTabs.Left = 0
FolderTabs.Top = 0
Folders(0).Left = 0
Folders(0).Top = OneTabHeight * (NumRows - 1)
For CH = 1 To NumFolders
Folders(CH).Left = 0
Folders(CH).Top = Folders(0).Top
Next CH
' Find the height of the caption
CH = TwipsY(GetSystemMetrics(4))
' Is there a menu?
If GetMenu(CInt(FolderTabs.Parent.hWnd)) <> 0 Then
MH = TwipsY(GetSystemMetrics(15)) ' Get the menu's height
Select Case FolderTabs.Parent.BorderStyle
Case 2 ' Sizable
SB = 2 * GetSystemMetrics(32)
Case Else ' Little known fact: with a menu, your window's
' borders can only be sizable or single.
SB = 2 * GetSystemMetrics(5)
End Select
OY = -1
Else
Select Case FolderTabs.Parent.BorderStyle
Case 0
SB = 0
CH = 0
Case 1
SB = 2 * GetSystemMetrics(5)
OY = -1
Case 2
SB = 2 * GetSystemMetrics(32)
OY = -1
Case 3
SB = 2 * GetSystemMetrics(7)
OX = 2
OY = 1
End Select
End If
FolderTabs.Parent.Height = Folders(0).Height + TwipsY(SB) + CH + MH + TwipsY(OY) + Folders(0).Top
FolderTabs.Parent.Width = Folders(0).Width + TwipsX(SB) + TwipsX(OX)
DrawTabs
End Sub
' Calculate the number of twips in a horizontal pixel
Private Function TwipsX (Pixels As Long) As Long
TwipsX = Pixels * screen.TwipsPerPixelX
End Function
' Calculate the number of twips in a vertical pixel
Private Function TwipsY (Pixels As Long) As Long
TwipsY = Pixels * screen.TwipsPerPixelY
End Function
' Calculate the row of a particular tab
Private Function VerTabPos (TN As Integer) As Integer
Dim I As Integer
Dim J As Integer
I = TN \ VisibleTabs + 1
J = FolderNum \ VisibleTabs + 1
If I >= J Then
VerTabPos = I - J + 1
ElseIf J > I Then
VerTabPos = NumRows - (J - I) + 1
End If
End Function