VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "cToolbar" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '============================================================================================================= ' ' cToolbar Class Module ' --------------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Created On : May 17, 2003 ' Last Update : May 26, 2003 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : modBitmap.bas (Bitmap manipulation module by Kevin Wilson [The VB Zone]) ' modTimer.bas (Timer module by Kevin Wilson [The VB Zone]) ' cTimer.cls (Timer class module by Kevin Wilson [The VB Zone]) ' ' Description : This class module takes a standard PictureBox control and turns it into a fully functional ' toolbar control... all with NO external dependencies ' ' IMPORTANT : Add the following to the "General Declarations" section of the "modTimer.bas" module: ' ' Public oTlBr As cToolbar ' WARNING: This object is used by the "cToolbar" code - DO NOT alter or remove it. ' ' Then add the following to the "TimeProc" CALLBACK function of the "modTimer.bas" module: ' ' If Not oTlBr Is Nothing Then ' oTlBr.Toolbar_Refresh ' Set oTlBr = Nothing ' End If ' ' Example Use : '_____________________________________________________________________________________________________________ ' ' Option Explicit ' Private WithEvents objToolbar As cToolbar ' Private objPic As StdPicture ' Private Sub Form_Click() ' objToolbar.Toolbar_Visible = Not objToolbar.Toolbar_Visible ' End Sub ' Private Sub Form_Load() ' Me.Visible = True ' Me.AutoRedraw = True ' Me.CurrentY = 50 ' Set objPic = LoadPicture("C:\TEST.ICO") ' Set objToolbar = New cToolbar ' Set objToolbar.PictureBoxToUse = Picture1 ' With objToolbar ' .Buttons_Style = as_Flat ' .Buttons_Add , bt_Default, "TEST", "DESC", "TT - TEST", objPic, , 1 ' .Buttons_Add , bt_Check, "TEST1", "DESC1", "TT - TEST1", imgIcon(0).Picture, , 2 ' .Buttons_Add , bt_Default, "TEST2", "DESC2", "TT - TEST2", imgIcon(1).Picture, , 3 ' .Buttons_Add , bt_Seperator, "TEST3", "DESC3", "TT - TEST3", imgIcon(1).Picture, , 4 ' .Buttons_Add , bt_Default, "TEST4", "DESC4", "TT - TEST4", imgIcon(2).Picture, , 5 ' End With ' End Sub ' Private Sub Form_Unload(Cancel As Integer) ' Set objPic = Nothing ' Set objToolbar = Nothing ' End Sub ' Private Sub objToolbar_ButtonClick(ByVal ID As Integer, ByVal Key As String, ByVal Desc As String, ByVal Order As Integer, ByVal ButtonType As ButtonTypes, ByVal Pressed As Boolean, ByVal ToolTipText As String, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ' If ButtonType = bt_Check Then ' Me.Print "You clicked button " & ID & " (" & Desc & ") - CHECKED = " & Pressed ' Else ' Me.Print "You clicked button " & ID & " (" & Desc & ")" ' End If ' End Sub ' Private Sub objToolbar_ButtonMouseMove(ByVal ID As Integer, ByVal Key As String, ByVal Desc As String, ByVal Order As Integer, ByVal ButtonType As ButtonTypes, ByVal Pressed As Boolean, ByVal ToolTipText As String, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ' Me.Caption = ToolTipText ' End Sub ' '============================================================================================================= ' ' LEGAL: ' ' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit ' given where credit is due. Also, it is not required, but it would be appreciated if you would mention ' somewhere in your compiled program that that your program makes use of code written and distributed by ' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles. ' ' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server ' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products, ' utilities, or applications that directly compete with products, utilities, and applications created by Kevin ' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first ' obtaining the written consent of the author Kevin Wilson. ' ' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without ' warning or notice. Copyrightİ by Kevin Wilson. All rights reserved. ' '============================================================================================================= ' Type - Button Information Private Type ButtonInfo Key As String Description As String ToolTipText As String Type As ButtonTypes Pressed As Boolean Deleted As Boolean Enabled As Boolean Visible As Boolean Transparent As Boolean PicID As Integer Order As Integer Location As RECT End Type ' Enumeration - Edge Appearance Public Enum AppearanceStyles as_3D = 0 as_Flat = 1 End Enum ' Enuemration - Edge Style Public Enum BorderStyles bs_None = 0 bs_FixedSingle = 1 End Enum ' Enumeration - Button Type Public Enum ButtonTypes bt_Default = 0 bt_Check = 1 bt_Seperator = 2 End Enum ' Constants - DrawEdge(lngFlags_Style) Private Const BDR_RAISEDOUTER As Long = &H1 ' Raised outer edge. Private Const BDR_SUNKENOUTER As Long = &H2 ' Sunken outer edge. Private Const BDR_RAISEDINNER As Long = &H4 ' Raised inner edge. Private Const BDR_SUNKENINNER As Long = &H8 ' Sunken inner edge. Private Const EDGE_BUMP As Long = (BDR_RAISEDOUTER Or BDR_SUNKENINNER) ' Combination of BDR_RAISEDOUTER and BDR_SUNKENINNER. Private Const EDGE_ETCHED As Long = (BDR_SUNKENOUTER Or BDR_RAISEDINNER) ' Combination of BDR_SUNKENOUTER and BDR_RAISEDINNER. Private Const EDGE_RAISED As Long = (BDR_RAISEDOUTER Or BDR_RAISEDINNER) ' Combination of BDR_RAISEDOUTER and BDR_RAISEDINNER. Private Const EDGE_SUNKEN As Long = (BDR_SUNKENOUTER Or BDR_SUNKENINNER) ' Combination of BDR_SUNKENOUTER and BDR_SUNKENINNER. ' Constants - DrawEdge(lngFlags_Edge) Private Const BF_LEFT As Long = &H1 ' Left side of border rectangle. Private Const BF_TOP As Long = &H2 ' Top of border rectangle. Private Const BF_RIGHT As Long = &H4 ' Right side of border rectangle. Private Const BF_BOTTOM As Long = &H8 ' Bottom of border rectangle. Private Const BF_TOPLEFT As Long = (BF_TOP Or BF_LEFT) ' Top and left side of border rectangle. Private Const BF_TOPRIGHT As Long = (BF_TOP Or BF_RIGHT) ' Top and right side of border rectangle. Private Const BF_BOTTOMLEFT As Long = (BF_BOTTOM Or BF_LEFT) ' Bottom and left side of border rectangle. Private Const BF_BOTTOMRIGHT As Long = (BF_BOTTOM Or BF_RIGHT) ' Bottom and right side of border rectangle. Private Const BF_RECT As Long = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM) ' Entire border rectangle. Private Const BF_DIAGONAL As Long = &H10 ' Diagonal border. Private Const BF_DIAGONAL_ENDTOPRIGHT As Long = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT) ' Diagonal border. The end point is the top-right corner of the rectangle; the origin is bottom-left corner. Private Const BF_DIAGONAL_ENDTOPLEFT As Long = (BF_DIAGONAL Or BF_TOP Or BF_LEFT) ' Diagonal border. The end point is the top-left corner of the rectangle; the origin is bottom-right corner. Private Const BF_DIAGONAL_ENDBOTTOMLEFT As Long = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT) ' Diagonal border. The end point is the bottom-left corner of the rectangle; the origin is top-right corner. Private Const BF_DIAGONAL_ENDBOTTOMRIGHT As Long = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT) ' Diagonal border. The end point is the bottom-right corner of the rectangle; the origin is top-left corner. Private Const BF_MIDDLE As Long = &H800 ' Interior of rectangle to be filled. Private Const BF_SOFT As Long = &H1000 ' Soft buttons instead of tiles. Private Const BF_ADJUST As Long = &H2000 ' Rectangle to be adjusted to leave space for client area. Private Const BF_FLAT As Long = &H4000 ' Flat border. Private Const BF_MONO As Long = &H8000 ' One-dimensional border. ' Constants - Toolbar Layout Private Const TB_PADDING_BARS As Byte = 3 ' The amount of space to the LEFT of the bars in the toolbar (if bar count is greater than 0) Private Const TB_PADDING_LEFT As Byte = 2 ' The amount of spaces to the LEFT of the first button on the toolbar Private Const TB_PADDING_TOP As Byte = 1 ' The amount of space seperating the top of the toolbar from the buttons in it Private Const TB_PADDING_BOTTOM As Byte = 1 ' The amount of space seperating the bottom of the toolbar from the buttons in it Private Const TB_PADDING_BUTTON As Byte = 2 ' The amount of space sperating the edge of the buttons from the pictures within them Private Const TB_BAR_THICKNESS As Byte = 3 ' The thickness of the toolbar bars (if bar count is greater than 0) Private Const TB_BUTTON_MAX_H As Byte = 16 ' Height of the buttons. WARNING: Do not change this. You must alter the code if you alter this constant. Private Const TB_BUTTON_MAX_W As Byte = 16 ' Width of the buttons. WARNING: Do not change this. You must alter the code if you alter this constant. Private Const TB_REFRESH_TIME As Integer = 1500 ' The time (in milliseconds) before a FLAT style button is returned to its default state once the user has put their mouse over it Private Const TB_PADDING_SPACER As Byte = 2 ' The amount of pixels on either side of spacers Private Const TB_SPACER_WIDTH As Byte = 2 ' The thickness of the spacers ' Local Variable Declarations Private objTimer As cTimer Private blnReady As Boolean Private intLastMouseOver As Integer Private intLastMouseDown As Integer Private blnMouseDown As Boolean ' Property Variable Declarations Private WithEvents p_PictureBox As PictureBox Attribute p_PictureBox.VB_VarHelpID = -1 Private p_Buttons() As ButtonInfo Private p_ButtonsCount As Integer Private p_Pictures() As StdPicture Private p_PicturesCount As Integer Private p_ButtonStyle As AppearanceStyles Private p_BackColor As Long Private p_TransColor As Long Private p_ToolbarTips As Boolean Private p_ToolbarSeperate As Boolean Private p_ToolbarStyle As AppearanceStyles Private p_ToolbarBorder As BorderStyles Private p_BarCount As Byte Private p_ButtonSpacing As Byte ' Win32 API Declarations Private Declare Function DrawEdge Lib "USER32.DLL" (ByVal hDC As Long, ByRef lpBox As RECT, ByVal lngFlags_Style As Long, ByVal lngFlags_Edge As Long) As Long 'BOOL Private Declare Function FillRect Lib "USER32.DLL" (ByVal hDC As Long, ByRef lpBox As RECT, ByVal hBRUSH As Long) As Long Private Declare Function CreateSolidBrush Lib "GDI32.DLL" (ByVal lngColor As Long) As Long Private Declare Function FrameRect Lib "USER32.DLL" (ByVal hDC As Long, ByRef lpBox As RECT, ByVal hBRUSH As Long) As Long '_____________________________________________________________________________________________________________ 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXX PUBLIC EVENT DECLARATIONS XXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ Public Event ButtonClick(ByVal ID As Integer, ByVal Key As String, ByVal Desc As String, ByVal Order As Integer, ByVal ButtonType As ButtonTypes, ByVal Pressed As Boolean, ByVal ToolTipText As String, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) Public Event ButtonMouseMove(ByVal ID As Integer, ByVal Key As String, ByVal Desc As String, ByVal Order As Integer, ByVal ButtonType As ButtonTypes, ByVal Pressed As Boolean, ByVal ToolTipText As String, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) Public Event Change() Public Event Click() Public Event DblClick() Public Event DragDrop(Source As Control, X As Single, Y As Single) Public Event DragOver(Source As Control, X As Single, Y As Single, State As Integer) Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Public Event OLECompleteDrag(Effect As Long) Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) Public Event OLESetData(Data As DataObject, DataFormat As Integer) Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) '_____________________________________________________________________________________________________________ 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXX CLASS EVENTS XXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ Private Sub Class_Initialize() ' Set initial property values Erase p_Buttons p_ButtonsCount = 0 Erase p_Pictures p_PicturesCount = 0 p_ButtonStyle = as_3D p_BackColor = TranslateColor(vbButtonFace) p_TransColor = vbMagenta p_ToolbarTips = True p_ToolbarSeperate = True p_ToolbarStyle = as_Flat p_ToolbarBorder = bs_FixedSingle p_BarCount = 1 p_ButtonSpacing = 1 intLastMouseOver = -1 End Sub Private Sub Class_Terminate() ' Clear the information currently held on the buttons Erase p_Buttons p_ButtonsCount = 0 Erase p_Pictures p_PicturesCount = 0 ' Reset the picturebox If Not p_PictureBox Is Nothing Then Set p_PictureBox = Nothing End If ' If the timer was previously set, reset it Call ResetTimer End Sub '_____________________________________________________________________________________________________________ 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXX PROPERTY DECLARATIONS XXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ Public Property Get PictureBoxToUse() As PictureBox Set PictureBoxToUse = p_PictureBox End Property Public Property Set PictureBoxToUse(ByVal NewValue As PictureBox) ' Clear the old PictureBox If Not p_PictureBox Is Nothing Then blnReady = False p_PictureBox.Cls p_PictureBox.Refresh blnReady = True End If ' Set the new PictureBox Set p_PictureBox = NewValue If p_PictureBox Is Nothing Then Exit Property blnReady = False With p_PictureBox ' VISUAL BASIC 6.0 ONLY 'If .HasDC = False Then Err.Raise -1, "cToolbar.PictureBoxToUse", "PictureBox control must have 'HasDC' property set to TRUE" '.Appearance = 0 'Flat .Align = 1 ' Top .AutoRedraw = True .AutoSize = False .BackColor = p_BackColor .BorderStyle = 0 'None .ScaleMode = vbPixels .ToolTipText = "" .OLEDragMode = 0 'Manual .OLEDropMode = 0 'None .MousePointer = 0 'Default .TabStop = False Set .MouseIcon = Nothing Set .DragIcon = Nothing Set .Picture = Nothing .Cls .Refresh .Visible = True End With blnReady = True ' Refresh the display Call Resize Call Refresh End Property Public Property Get Buttons_Spacing() As Byte Buttons_Spacing = p_ButtonSpacing End Property Public Property Let Buttons_Spacing(ByVal NewValue As Byte) If NewValue < 0 Then NewValue = 0 If NewValue > 20 Then NewValue = 20 p_ButtonSpacing = NewValue ' Refresh the display Call Refresh End Property Public Property Get Buttons_Style() As AppearanceStyles Buttons_Style = p_ButtonStyle End Property Public Property Let Buttons_Style(ByVal NewValue As AppearanceStyles) If NewValue <> as_3D And NewValue <> as_Flat Then Err.Raise -1, "cToolbar.Buttons_Style", "Invalid property value specified" p_ButtonStyle = NewValue ' Refresh the display Call Refresh End Property Public Property Get Buttons_Enabled(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String) As Boolean ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Enabled(Get)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Enabled(Get)", "No valid button ID or Key provided" ' Return the information Buttons_Enabled = p_Buttons(intButtonID).Enabled End Property Public Property Let Buttons_Enabled(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String, ByVal NewValue As Boolean) ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Enabled(Let)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Enabled(Let)", "No valid button ID or Key provided" ' Set the new information If p_Buttons(intButtonID).Type <> bt_Seperator Then p_Buttons(intButtonID).Enabled = NewValue Else p_Buttons(intButtonID).Enabled = False End If ' Refresh the display Call Refresh End Property Public Property Get Buttons_Visible(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String) As Boolean ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Visible(Get)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Visible(Get)", "No valid button ID or Key provided" ' Return the information Buttons_Visible = p_Buttons(intButtonID).Visible End Property Public Property Let Buttons_Visible(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String, ByVal NewValue As Boolean) ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Visible(Let)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Visible(Let)", "No valid button ID or Key provided" ' Set the new information With p_Buttons(intButtonID).Location .Left = -1 .Top = -1 .Right = -1 .Bottom = -1 End With p_Buttons(intButtonID).Visible = NewValue ' Refresh the display Call Refresh End Property Public Property Get Buttons_ToolTipText(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String) As String ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_ToolTipText(Get)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_ToolTipText(Get)", "No valid button ID or Key provided" ' Return the information If p_Buttons(intButtonID).Type = bt_Seperator Then Buttons_ToolTipText = "" Else Buttons_ToolTipText = p_Buttons(intButtonID).ToolTipText End If End Property Public Property Let Buttons_ToolTipText(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String, ByVal NewValue As String) ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_ToolTipText(Let)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_ToolTipText(Let)", "No valid button ID or Key provided" ' Set the new information If p_Buttons(intButtonID).Type <> bt_Seperator Then p_Buttons(intButtonID).ToolTipText = NewValue Else p_Buttons(intButtonID).ToolTipText = "" End If End Property Public Property Get Buttons_Description(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String) As String ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Description(Get)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Description(Get)", "No valid button ID or Key provided" ' Return the information Buttons_Description = p_Buttons(intButtonID).Description End Property Public Property Let Buttons_Description(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String, ByVal NewValue As String) ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Description(Let)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Description(Let)", "No valid button ID or Key provided" ' Set the new information p_Buttons(intButtonID).Description = NewValue End Property Public Property Get Buttons_Pressed(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String) As Boolean ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Pressed(Get)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Pressed(Get)", "No valid button ID or Key provided" ' Return the information Buttons_Pressed = p_Buttons(intButtonID).Pressed End Property Public Property Let Buttons_Pressed(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String, ByVal NewValue As Boolean) ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Pressed(Let)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Pressed(Let)", "No valid button ID or Key provided" ' Set the new information p_Buttons(intButtonID).Pressed = NewValue ' Refresh the display Call Refresh End Property Public Property Get Buttons_Transparent(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String) As Boolean ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Transparent(Get)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Transparent(Get)", "No valid button ID or Key provided" ' Return the information Buttons_Transparent = p_Buttons(intButtonID).Transparent End Property Public Property Let Buttons_Transparent(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String, ByVal NewValue As Boolean) ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Transparent(Let)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Transparent(Let)", "No valid button ID or Key provided" ' Set the new information p_Buttons(intButtonID).Transparent = NewValue ' Refresh the display Call Refresh End Property Public Property Get Buttons_Order(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String) As Integer ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Order(Get)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Order(Get)", "No valid button ID or Key provided" ' Return the information Buttons_Order = p_Buttons(intButtonID).Order End Property Public Property Let Buttons_Order(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String, ByVal NewValue As Integer) ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Order(Let)", "No valid button ID or Key provided" If NewValue < 1 Then NewValue = 1 If NewValue > p_ButtonsCount Then NewValue = p_ButtonsCount ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Order(Let)", "No valid button ID or Key provided" ' Set the new information p_Buttons(intButtonID).Order = NewValue ' Refresh the display Call Refresh End Property Public Property Get Buttons_Type(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String) As ButtonTypes ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Type(Get)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Type(Get)", "No valid button ID or Key provided" ' Return the information Buttons_Type = p_Buttons(intButtonID).Type End Property Public Property Let Buttons_Type(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String, ByVal NewValue As ButtonTypes) Dim intPicID As Integer ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Type(Let)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Type(Let)", "No valid button ID or Key provided" ' Seperators don't have pictures assigned to them If NewValue = bt_Seperator Then With p_Buttons(intButtonID) ' Check if the Picture ID is used by any other button. If it is not, take it out of the picture array Call RemovePic(.PicID, intButtonID) ' Seperators are DISABLED and don't have ToolTipText values .Enabled = False .ToolTipText = "" .Pressed = False End With ElseIf p_Buttons(intButtonID).Type = bt_Seperator And NewValue <> bt_Seperator Then p_Buttons(intButtonID).Enabled = True End If ' Set the new information p_Buttons(intButtonID).Type = NewValue ' Refresh the display Call Refresh End Property Public Property Get Buttons_Picture(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String) As StdPicture ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Picture(Get)", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Picture(Get)", "No valid button ID or Key provided" ' Return the information If p_Buttons(intButtonID).PicID > -1 And p_Buttons(intButtonID).PicID < p_PicturesCount Then Set Buttons_Picture = p_Pictures(p_Buttons(intButtonID).PicID) End If End Property Public Property Set Buttons_Picture(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String, ByRef NewValue As StdPicture) Dim intID As Integer Dim intCounter As Integer Dim blnFoundIt As Boolean ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Picture(Set)", "No valid button ID or Key provided" ' Get the button ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Picture(Set)", "No valid button ID or Key provided" ' If the button is a seperator, just exit If p_Buttons(intButtonID).Type = bt_Seperator Then p_Buttons(intButtonID).PicID = -1 Exit Property End If ' Get the picture ID intID = GetPictureIndex(NewValue) If intID = -1 Then If NewValue Is Nothing Then p_Buttons(intButtonID).PicID = -1 Else p_PicturesCount = p_PicturesCount + 1 ReDim Preserve p_Pictures(0 To p_PicturesCount - 1) As StdPicture Set p_Pictures(p_PicturesCount - 1) = NewValue p_Buttons(intButtonID).PicID = p_PicturesCount - 1 End If Else p_Buttons(intButtonID).PicID = intID End If ' Refresh the display Call Refresh End Property Public Property Get Buttons_Count() As Integer Buttons_Count = p_ButtonsCount End Property Public Property Get Buttons_TransparentColor() As Long Buttons_TransparentColor = p_TransColor End Property Public Property Let Buttons_TransparentColor(ByVal NewValue As Long) Dim lngTemp As Long lngTemp = TranslateColor(NewValue) If lngTemp = -1 Then Err.Raise -1, "cToolbar.Toolbar_BackColor", "Invalid color value specified" p_TransColor = lngTemp ' Refresh the display Call Refresh End Property Public Property Get Toolbar_BarCount() As Byte Toolbar_BarCount = p_BarCount End Property Public Property Let Toolbar_BarCount(ByVal NewValue As Byte) If NewValue < 0 Then p_BarCount = 0 ElseIf NewValue > 2 Then p_BarCount = 2 Else p_BarCount = NewValue End If ' Refresh the display Call Refresh End Property Public Property Get Toolbar_BackColor() As Long Toolbar_BackColor = p_BackColor End Property Public Property Let Toolbar_BackColor(ByVal NewValue As Long) Dim lngTemp As Long lngTemp = TranslateColor(NewValue) If lngTemp = -1 Then Err.Raise -1, "cToolbar.Toolbar_BackColor", "Invalid color value specified" p_BackColor = lngTemp If Not p_PictureBox Is Nothing Then p_PictureBox.BackColor = lngTemp ' Refresh the display Call Refresh End Property Public Property Get Toolbar_Style() As AppearanceStyles Toolbar_Style = p_ToolbarStyle End Property Public Property Let Toolbar_Style(ByVal NewValue As AppearanceStyles) If NewValue <> as_3D And NewValue <> as_Flat Then Err.Raise -1, "cToolbar.Toolbar_Style", "Invalid property value specified" p_ToolbarStyle = NewValue ' Refresh the display Call Refresh End Property Public Property Get Toolbar_Border() As BorderStyles Toolbar_Border = p_ToolbarBorder End Property Public Property Let Toolbar_Border(ByVal NewValue As BorderStyles) If NewValue <> bs_None And NewValue <> bs_FixedSingle Then Err.Raise -1, "cToolbar.Toolbar_Border", "Invalid property value specified" p_ToolbarBorder = NewValue ' Refresh the display Call Refresh End Property Public Property Get Toolbar_ShowSeperator() As Boolean Toolbar_ShowSeperator = p_ToolbarSeperate End Property Public Property Let Toolbar_ShowSeperator(ByVal NewValue As Boolean) p_ToolbarSeperate = NewValue Call Refresh End Property Public Property Get Toolbar_ShowToolTips() As Boolean Toolbar_ShowToolTips = p_ToolbarTips End Property Public Property Let Toolbar_ShowToolTips(ByVal NewValue As Boolean) p_ToolbarTips = NewValue End Property Public Property Get Toolbar_Enabled() As Boolean If Not p_PictureBox Is Nothing Then Toolbar_Enabled = p_PictureBox.Enabled Else Toolbar_Enabled = False End Property Public Property Let Toolbar_Enabled(ByVal NewValue As Boolean) If Not p_PictureBox Is Nothing Then p_PictureBox.Enabled = NewValue End Property Public Property Get Toolbar_Visible() As Boolean If Not p_PictureBox Is Nothing Then Toolbar_Visible = p_PictureBox.Visible Else Toolbar_Visible = False End Property Public Property Let Toolbar_Visible(ByVal NewValue As Boolean) If Not p_PictureBox Is Nothing Then p_PictureBox.Visible = NewValue End Property '_____________________________________________________________________________________________________________ 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXX METHOD DECLARATIONS XXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ Public Function Buttons_Add(Optional ByRef Return_ButtonIndex As Integer, Optional ByVal lngButtonType As ButtonTypes = bt_Default, Optional ByVal strKey As String = "", Optional ByVal strDescription As String = "", Optional ByVal strToolTipText As String = "", Optional ByRef objPicture As StdPicture, Optional ByVal blnTransparent As Boolean = True, Optional ByVal intOrder As Integer = -1) As Boolean Dim intPicID As Integer Dim intButtonID As Integer Dim intCounter As Integer Dim lngWidth As Long Dim lngHeight As Long strKey = Trim(strKey) If Buttons_IdFromKey(strKey) <> -1 Then Err.Raise -1, "cToolbar.Buttons_Add", "The key " & Chr(34) & strKey & Chr(34) & " already exists" End If intPicID = -1 If Not objPicture Is Nothing And lngButtonType <> bt_Seperator Then If objPicture.Type <> vbPicTypeBitmap And objPicture.Type <> vbPicTypeIcon Then Err.Raise -1, "cToolbar.Buttons_Add", "Invalid picture type specified for button" Else If Convert_HM_PX(objPicture.Height, objPicture.Width, lngHeight, lngWidth, True) = False Then Err.Raise -1, "cToolbar.Buttons_Add", "Failed to convert picture dimentions" ElseIf lngWidth > TB_BUTTON_MAX_W Or lngHeight > TB_BUTTON_MAX_H Then Err.Raise -1, "cToolbar.Buttons_Add", "Picture dimentions are too large. Must be less than 16x16." End If End If intPicID = GetPictureIndex(objPicture) If intPicID < 0 Then p_PicturesCount = p_PicturesCount + 1 ReDim Preserve p_Pictures(0 To p_PicturesCount - 1) As StdPicture Set p_Pictures(p_PicturesCount - 1) = objPicture intPicID = p_PicturesCount - 1 End If End If If p_ButtonsCount < 1 Then p_ButtonsCount = 1 ReDim p_Buttons(0 To 0) As ButtonInfo With p_Buttons(0) .Key = strKey .Description = strDescription If lngButtonType <> bt_Seperator Then .ToolTipText = strToolTipText Else .ToolTipText = "" .Type = lngButtonType .Pressed = False .Deleted = False .Enabled = Not (lngButtonType = bt_Seperator) .Visible = True .Transparent = blnTransparent .PicID = intPicID .Order = 1 .Location.Bottom = -1 .Location.Left = -1 .Location.Right = -1 .Location.Top = -1 End With intButtonID = 0 Else intButtonID = -1 For intCounter = 0 To p_ButtonsCount - 1 If p_Buttons(intCounter).Deleted = True Then intButtonID = intCounter Exit For End If Next If intButtonID < 0 Then p_ButtonsCount = p_ButtonsCount + 1 ReDim Preserve p_Buttons(0 To p_ButtonsCount - 1) As ButtonInfo intButtonID = p_ButtonsCount - 1 End If If intOrder < 1 Then intOrder = 1 If intOrder > p_ButtonsCount Then intOrder = p_ButtonsCount With p_Buttons(intButtonID) .Key = strKey .Description = strDescription .ToolTipText = strToolTipText .Type = lngButtonType .Pressed = False .Deleted = False .Enabled = Not (lngButtonType = bt_Seperator) .Visible = True .Transparent = blnTransparent .PicID = intPicID .Order = intOrder .Location.Bottom = -1 .Location.Left = -1 .Location.Right = -1 .Location.Top = -1 End With End If ' Refresh the display Call Refresh End Function Public Function Buttons_Remove(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String) As Boolean Dim intCounter As Integer Dim blnFoundIt As Boolean ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Remove", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Remove", "No valid button ID or Key provided" ' If there's only one button, clear the button and picture information If p_ButtonsCount = 1 Then Erase p_Buttons p_ButtonsCount = 0 Erase p_Pictures p_PicturesCount = 0 Call Refresh Buttons_Remove = True Exit Function End If ' Check if the Picture ID is used by any other button. If it is not, take it out of the picture array Call RemovePic(p_Buttons(intButtonID).PicID, intButtonID) ' Delete the selected button ClearButton intButtonID ' Refresh the display Call Refresh Buttons_Remove = True End Function Public Sub Buttons_Clear() ' Clear the information currently held on the buttons Erase p_Buttons p_ButtonsCount = 0 Erase p_Pictures p_PicturesCount = 0 ' Refresh the display Call Refresh End Sub Public Function Buttons_Location(Optional ByVal intButtonID As Integer = -1, Optional ByVal strButtonKey As String, Optional ByRef Return_Left As Long, Optional ByRef Return_Top As Long, Optional ByRef Return_Right As Long, Optional ByRef Return_Bottom As Long) As Boolean ' Set default values Return_Left = -1 Return_Top = -1 Return_Right = -1 Return_Bottom = -1 ' Validate parameters strButtonKey = Trim(strButtonKey) If intButtonID < 0 And strButtonKey = "" Then Err.Raise -1, "cToolbar.Buttons_Location", "No valid button ID or Key provided" ' Get the ID intButtonID = GetButtonID(intButtonID, strButtonKey) If intButtonID = -1 Then Err.Raise -1, "cToolbar.Buttons_Location", "No valid button ID or Key provided" ' Return the information With p_Buttons(intButtonID).Location Return_Left = .Left Return_Top = .Top Return_Right = .Right Return_Bottom = .Bottom End With Buttons_Location = True End Function Public Function Buttons_IdFromKey(ByVal strKey As String) As Integer Dim intCounter As Integer ' Set default value Buttons_IdFromKey = -1 ' Validate parameters strKey = UCase(Trim(strKey)) If strKey = "" Then Exit Function If p_ButtonsCount < 1 Then Exit Function ' Loop through the buttons and check for a matching key For intCounter = 0 To p_ButtonsCount - 1 If p_Buttons(intCounter).Deleted = False Then If UCase(Trim(p_Buttons(intCounter).Key)) = strKey Then Buttons_IdFromKey = intCounter Exit For End If End If Next End Function Public Sub Toolbar_Refresh() ' If the timer was previously set, reset it Call ResetTimer ' Refresh the display Call Refresh End Sub '_____________________________________________________________________________________________________________ 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXX PICTUREBOX EVENTS XXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ Private Sub p_PictureBox_Change() If blnReady = False Then Exit Sub RaiseEvent Change End Sub Private Sub p_PictureBox_Click() If blnReady = False Then Exit Sub If intLastMouseDown > -1 Then If p_Buttons(intLastMouseDown).Enabled = True Then If p_Buttons(intLastMouseDown).Type = bt_Check Then p_Buttons(intLastMouseDown).Pressed = Not p_Buttons(intLastMouseDown).Pressed End If Call Refresh RaiseEvent ButtonClick(intLastMouseDown, p_Buttons(intLastMouseDown).Key, p_Buttons(intLastMouseDown).Description, p_Buttons(intLastMouseDown).Order, p_Buttons(intLastMouseDown).Type, p_Buttons(intLastMouseDown).Pressed, p_Buttons(intLastMouseDown).ToolTipText, p_Buttons(intLastMouseDown).Location.Left, p_Buttons(intLastMouseDown).Location.Top, p_Buttons(intLastMouseDown).Location.Right, p_Buttons(intLastMouseDown).Location.Bottom) End If End If RaiseEvent Click End Sub Private Sub p_PictureBox_DblClick() If blnReady = False Then Exit Sub RaiseEvent DblClick End Sub Private Sub p_PictureBox_DragDrop(Source As Control, X As Single, Y As Single) If blnReady = False Then Exit Sub RaiseEvent DragDrop(Source, X, Y) End Sub Private Sub p_PictureBox_DragOver(Source As Control, X As Single, Y As Single, State As Integer) If blnReady = False Then Exit Sub RaiseEvent DragOver(Source, X, Y, State) End Sub Private Sub p_PictureBox_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim intCounter As Integer Dim intCurrent As Integer If blnReady = False Then Exit Sub ' Indicate that the mouse is down... so MouseMove events don't messup the drawing of the toolbar blnMouseDown = True If Not p_PictureBox Is Nothing Then ' If the timer was previously set, reset it Call ResetTimer ' Clear all previous outlines Call Refresh intCurrent = -1 If p_ButtonsCount > 0 Then ' Loop through the buttons and see if the cursor is currently within any of their bounds For intCounter = 0 To p_ButtonsCount - 1 With p_Buttons(intCounter).Location If X >= .Left And X <= .Right And Y >= .Top And Y <= .Bottom Then intCurrent = intCounter Exit For End If End With Next If intCurrent > -1 Then If p_Buttons(intCurrent).Enabled = True Then ' Draw the DEPRESSED border around the NEW button If p_ButtonStyle = as_3D Then DrawEdge p_PictureBox.hDC, p_Buttons(intCurrent).Location, BDR_SUNKENOUTER Or BDR_SUNKENINNER, BF_RECT Else DrawEdge p_PictureBox.hDC, p_Buttons(intCurrent).Location, BDR_SUNKENOUTER, BF_RECT End If p_PictureBox.Refresh ' Remember the last button that was outlined intLastMouseOver = intCurrent intLastMouseDown = intCurrent End If End If End If End If RaiseEvent MouseDown(Button, Shift, X, Y) End Sub Private Sub p_PictureBox_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim intCounter As Integer Dim hBRUSH As Long Dim intCurrent As Integer If blnReady = False Then Exit Sub If blnMouseDown = True Then Exit Sub intLastMouseDown = -1 If Not p_PictureBox Is Nothing Then intCurrent = -1 If p_ButtonsCount > 0 Then ' Loop through the buttons and see if the cursor is currently within any of their bounds For intCounter = 0 To p_ButtonsCount - 1 With p_Buttons(intCounter).Location If X >= .Left And X <= .Right And Y >= .Top And Y <= .Bottom Then intCurrent = intCounter Exit For End If End With Next ' Clear the border around the previous button If intLastMouseOver > -1 And intLastMouseOver <> intCurrent Then If p_Buttons(intLastMouseOver).Pressed = True Then If p_ButtonStyle = as_3D Then DrawEdge p_PictureBox.hDC, p_Buttons(intLastMouseOver).Location, BDR_SUNKENOUTER Or BDR_SUNKENINNER, BF_RECT Else DrawEdge p_PictureBox.hDC, p_Buttons(intLastMouseOver).Location, BDR_SUNKENOUTER, BF_RECT End If p_PictureBox.Refresh Else If p_ButtonStyle = as_3D Then DrawEdge p_PictureBox.hDC, p_Buttons(intLastMouseOver).Location, BDR_RAISEDOUTER Or BDR_RAISEDINNER, BF_RECT Else hBRUSH = CreateSolidBrush(p_BackColor) FrameRect p_PictureBox.hDC, p_Buttons(intLastMouseOver).Location, hBRUSH DeleteObject hBRUSH intLastMouseOver = -1 End If p_PictureBox.Refresh End If End If If intCurrent > -1 Then If p_ButtonStyle = as_Flat Then If p_Buttons(intCurrent).Pressed = True Or p_Buttons(intCurrent).Enabled = False Then 'DO NOTHING Else ' Draw the border around the NEW button DrawEdge p_PictureBox.hDC, p_Buttons(intCurrent).Location, BDR_RAISEDINNER, BF_RECT p_PictureBox.Refresh ' Remember the last button that was outlined intLastMouseOver = intCurrent ' If the timer was previously set, reset it Call ResetTimer ' Set a reference to the current toolbar Set oTlBr = Me ' Start a new timer Set objTimer = New cTimer objTimer.Interval = TB_REFRESH_TIME objTimer.Enabled = True End If End If If p_ToolbarTips = True And p_Buttons(intCurrent).Type <> bt_Seperator Then p_PictureBox.ToolTipText = p_Buttons(intCurrent).ToolTipText End If RaiseEvent ButtonMouseMove(intCurrent, p_Buttons(intCurrent).Key, p_Buttons(intCurrent).Description, p_Buttons(intCurrent).Order, p_Buttons(intCurrent).Type, p_Buttons(intCurrent).Pressed, p_Buttons(intCurrent).ToolTipText, p_Buttons(intCurrent).Location.Left, p_Buttons(intCurrent).Location.Top, p_Buttons(intCurrent).Location.Right, p_Buttons(intCurrent).Location.Bottom) Else ' If the timer was previously set, reset it Call ResetTimer p_PictureBox.ToolTipText = "" End If Else p_PictureBox.ToolTipText = "" End If End If RaiseEvent MouseMove(Button, Shift, X, Y) End Sub Private Sub p_PictureBox_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If blnReady = False Then Exit Sub ' Indicate that the mouse is no longer down blnMouseDown = False If Not p_PictureBox Is Nothing Then ' If the timer was previously set, reset it Call ResetTimer ' Clear all previous outlines Call Refresh End If RaiseEvent MouseUp(Button, Shift, X, Y) End Sub Private Sub p_PictureBox_OLECompleteDrag(Effect As Long) If blnReady = False Then Exit Sub RaiseEvent OLECompleteDrag(Effect) End Sub Private Sub p_PictureBox_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) If blnReady = False Then Exit Sub RaiseEvent OLEDragDrop(Data, Effect, Button, Shift, X, Y) End Sub Private Sub p_PictureBox_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) If blnReady = False Then Exit Sub RaiseEvent OLEDragOver(Data, Effect, Button, Shift, X, Y, State) End Sub Private Sub p_PictureBox_OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) If blnReady = False Then Exit Sub RaiseEvent OLEGiveFeedback(Effect, DefaultCursors) End Sub Private Sub p_PictureBox_OLESetData(Data As DataObject, DataFormat As Integer) If blnReady = False Then Exit Sub RaiseEvent OLESetData(Data, DataFormat) End Sub Private Sub p_PictureBox_OLEStartDrag(Data As DataObject, AllowedEffects As Long) If blnReady = False Then Exit Sub RaiseEvent OLEStartDrag(Data, AllowedEffects) End Sub Private Sub p_PictureBox_Paint() ' Resize the toolbar and refresh the display Call Refresh End Sub Private Sub p_PictureBox_Resize() ' Resize the toolbar and refresh the display Call Refresh End Sub '_____________________________________________________________________________________________________________ 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXX PRIVATE FUNCTION DECLARATIONS XXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ Private Function GetPictureIndex(ByRef objPicture As StdPicture) As Integer Dim intCounter As Integer ' Set default values GetPictureIndex = -1 ' Validate parameters If objPicture Is Nothing Then Exit Function If p_PicturesCount < 1 Then Exit Function ' Loop through the pictures looking for a match For intCounter = 0 To p_PicturesCount - 1 If Not p_Pictures(intCounter) Is Nothing Then With p_Pictures(intCounter) If objPicture.Handle = .Handle And objPicture.Type = .Type Then GetPictureIndex = intCounter Exit For End If End With End If Next End Function Private Function GetButtonID(ByVal intButtonID As Integer, ByVal strButtonKey As String) As Integer ' Set default values GetButtonID = -1 ' Validate parameters strButtonKey = Trim(strButtonKey) ' Get the ID If intButtonID > -1 Then If intButtonID < p_ButtonsCount Then If p_Buttons(intButtonID).Deleted = False Then GetButtonID = intButtonID Exit Function End If End If End If ' Find the ID GetButtonID = Buttons_IdFromKey(strButtonKey) End Function Private Sub ClearButton(ByVal intButtonID As Integer) On Error Resume Next If intButtonID < 0 Or intButtonID > UBound(p_Buttons) Then Exit Sub With p_Buttons(intButtonID) .Key = "" .Description = "" .ToolTipText = "" .Type = bt_Default .Pressed = False .Deleted = True .Enabled = False .Visible = False .Transparent = False .PicID = -1 .Order = -1 .Location.Bottom = -1 .Location.Left = -1 .Location.Right = -1 .Location.Top = -1 End With Err.Clear End Sub Private Sub Refresh() Const DEBUGGING As Boolean = False Dim rLocation As RECT Dim hBRUSH As Long Dim bytThickness As Byte Dim lngCurrentX As Long Dim lngTop As Long Dim lngBottom As Long Dim intCounter1 As Integer Dim intCounter2 As Integer Dim bytBorder As Byte ' If the PictureBox has not yet been set, exit If p_PictureBox Is Nothing Then Exit Sub ' Make sure we're ready before we do anything If blnReady = False Then Exit Sub ' Clear the previous contents p_PictureBox.Cls p_PictureBox.BackColor = p_BackColor ' Make sure the PictureBox is the right size Call Resize '------------------------------------------------------------------------------------- ' If the toolbar has a seperator, draw it If p_ToolbarSeperate = True Then With rLocation .Top = 0 .Left = (Screen.TwipsPerPixelX) * -1 .Right = p_PictureBox.ScaleWidth + (Screen.TwipsPerPixelX * 2) .Bottom = 2 End With DrawEdge p_PictureBox.hDC, rLocation, BDR_SUNKENOUTER, BF_RECT End If '------------------------------------------------------------------------------------- ' If the toolbar has an edge, draw it If p_ToolbarBorder = bs_FixedSingle Then With rLocation .Top = 0 .Left = 0 .Right = p_PictureBox.ScaleWidth .Bottom = p_PictureBox.ScaleHeight If p_ToolbarSeperate = True Then .Top = 2 End With If p_ToolbarStyle = as_3D Then bytThickness = 2 DrawEdge p_PictureBox.hDC, rLocation, BDR_RAISEDOUTER Or BDR_RAISEDINNER, BF_RECT Else bytThickness = 1 DrawEdge p_PictureBox.hDC, rLocation, BDR_RAISEDINNER, BF_RECT End If End If If DEBUGGING = True Then p_PictureBox.Refresh lngCurrentX = lngCurrentX + bytThickness lngTop = bytThickness + TB_PADDING_TOP If p_ToolbarSeperate = True Then lngTop = lngTop + 2 bytBorder = 1 If p_ButtonStyle = as_3D Then bytBorder = 2 lngBottom = bytThickness + TB_PADDING_TOP + bytBorder + TB_PADDING_BUTTON + TB_BUTTON_MAX_H + TB_PADDING_BUTTON + bytBorder If p_ToolbarSeperate = True Then lngBottom = lngBottom + 2 '------------------------------------------------------------------------------------- ' Draw the bars If p_BarCount > 0 Then With rLocation .Top = lngTop .Left = bytThickness + TB_PADDING_BARS .Right = .Left + TB_BAR_THICKNESS .Bottom = lngBottom End With DrawEdge p_PictureBox.hDC, rLocation, BDR_RAISEDINNER, BF_RECT lngCurrentX = lngCurrentX + TB_PADDING_BARS + TB_BAR_THICKNESS If p_BarCount = 2 Then rLocation.Left = rLocation.Right rLocation.Right = rLocation.Left + TB_BAR_THICKNESS DrawEdge p_PictureBox.hDC, rLocation, BDR_RAISEDINNER, BF_RECT lngCurrentX = lngCurrentX + TB_BAR_THICKNESS End If End If If DEBUGGING = True Then p_PictureBox.Refresh lngCurrentX = lngCurrentX + TB_PADDING_LEFT '------------------------------------------------------------------------------------- ' Draw buttons If p_ButtonsCount > 0 Then For intCounter1 = 1 To p_ButtonsCount For intCounter2 = 0 To p_ButtonsCount - 1 If p_Buttons(intCounter2).Order = intCounter1 And p_Buttons(intCounter2).Deleted = False And p_Buttons(intCounter2).Visible = True Then ' Draw the button's BORDER With p_Buttons(intCounter2).Location .Top = lngTop .Bottom = lngBottom If p_Buttons(intCounter2).Type = bt_Seperator Then .Left = lngCurrentX + TB_PADDING_SPACER .Right = .Left + TB_SPACER_WIDTH Else .Left = lngCurrentX .Right = .Left + bytBorder + TB_PADDING_BUTTON + TB_BUTTON_MAX_W + TB_PADDING_BUTTON + bytBorder End If End With If p_ButtonStyle = as_3D And p_Buttons(intCounter2).Type <> bt_Seperator Then If p_Buttons(intCounter2).Pressed = True Then DrawEdge p_PictureBox.hDC, p_Buttons(intCounter2).Location, BDR_SUNKENOUTER Or BDR_SUNKENINNER, BF_RECT Else DrawEdge p_PictureBox.hDC, p_Buttons(intCounter2).Location, BDR_RAISEDOUTER Or BDR_RAISEDINNER, BF_RECT End If Else If p_Buttons(intCounter2).Pressed = True Or p_Buttons(intCounter2).Type = bt_Seperator Then DrawEdge p_PictureBox.hDC, p_Buttons(intCounter2).Location, BDR_SUNKENOUTER, BF_RECT End If End If ' If an image is assigned to the current button, render it according to it's enabled state If p_Buttons(intCounter2).PicID > -1 Then With p_Pictures(p_Buttons(intCounter2).PicID) If .Type = vbPicTypeBitmap Then ' Render Transparent BITMAP If p_Buttons(intCounter2).Transparent = True Then If p_Buttons(intCounter2).Enabled = True Then RenderBitmapTransparent p_PictureBox.hDC, .Handle, p_TransColor, (lngCurrentX + bytBorder + TB_PADDING_BUTTON), (lngTop + bytBorder + TB_PADDING_BUTTON) Else RenderBitmapTransparentGS p_PictureBox.hDC, .Handle, p_TransColor, (lngCurrentX + bytBorder + TB_PADDING_BUTTON), (lngTop + bytBorder + TB_PADDING_BUTTON) End If ' Render NON-Transparent BITMAP Else If p_Buttons(intCounter2).Enabled = True Then RenderBitmap p_PictureBox.hDC, .Handle, (lngCurrentX + bytBorder + TB_PADDING_BUTTON), (lngTop + bytBorder + TB_PADDING_BUTTON) Else RenderBitmapGrayscale p_PictureBox.hDC, .Handle, (lngCurrentX + bytBorder + TB_PADDING_BUTTON), (lngTop + bytBorder + TB_PADDING_BUTTON), , , False End If End If ElseIf .Type = vbPicTypeIcon Then ' Render Icon If p_Buttons(intCounter2).Enabled = True Then RenderIcon p_PictureBox.hDC, .Handle, (lngCurrentX + bytBorder + TB_PADDING_BUTTON), (lngTop + bytBorder + TB_PADDING_BUTTON) Else RenderIconGrayscale p_PictureBox.hDC, .Handle, (lngCurrentX + bytBorder + TB_PADDING_BUTTON), (lngTop + bytBorder + TB_PADDING_BUTTON) End If End If End With End If ' Incrament the current location If p_Buttons(intCounter2).Type = bt_Seperator Then lngCurrentX = p_Buttons(intCounter2).Location.Right + TB_PADDING_SPACER + p_ButtonSpacing Else lngCurrentX = p_Buttons(intCounter2).Location.Right + p_ButtonSpacing End If End If Next intCounter2 Next intCounter1 End If '------------------------------------------------------------------------------------- ' Finished p_PictureBox.Refresh End Sub Private Sub Resize() Dim bytThickness As Byte Dim intHeight As Integer ' If the PictureBox has not yet been set, exit If p_PictureBox Is Nothing Then Exit Sub ' Make sure we're ready before we do anything If blnReady = False Then Exit Sub If p_ToolbarBorder = bs_FixedSingle Then If p_ToolbarStyle = as_Flat Then bytThickness = bytThickness + 1 Else bytThickness = bytThickness + 2 End If End If If p_ButtonStyle = as_Flat Then bytThickness = bytThickness + 1 Else bytThickness = bytThickness + 2 End If intHeight = (bytThickness * 2) + TB_PADDING_TOP + TB_PADDING_BUTTON + TB_BUTTON_MAX_H + TB_PADDING_BUTTON + TB_PADDING_BOTTOM If p_ToolbarSeperate = True Then intHeight = intHeight + 2 If p_PictureBox.Parent.ScaleMode = vbTwips Then p_PictureBox.Height = intHeight * Screen.TwipsPerPixelY Else p_PictureBox.Height = intHeight End If End Sub Private Sub ResetTimer() ' If a previous timer was started, end it If Not objTimer Is Nothing Then objTimer.Enabled = False Set objTimer = Nothing End If Set oTlBr = Nothing End Sub Private Sub RemovePic(ByVal intPicID As Integer, ByVal intButtonID As Integer) Dim intCounter As Integer Dim blnFoundIt As Boolean ' If there are more than one pictures in existance, continue If p_PicturesCount > 0 Then ' If the picture ID is valid, continue If intPicID > -1 And intPicID < p_PicturesCount Then ' Check if any other button uses the picture For intCounter = 0 To p_ButtonsCount - 1 If p_Buttons(intCounter).PicID = intPicID And intCounter <> intButtonID Then blnFoundIt = True Exit For End If Next ' If no other button uses the picture, delete it If blnFoundIt = False Then ' If there's only 1 picture, delete it If p_PicturesCount = 1 Then Erase p_Pictures p_PicturesCount = 0 ' Set the current button's PicID property to indicate there's no picture assigned to it p_Buttons(intButtonID).PicID = -1 Else ' Loop through all buttons and shift their PicID properties to point to the new location For intCounter = 0 To p_ButtonsCount - 1 If intCounter <> intButtonID Then If p_Buttons(intCounter).PicID = (p_PicturesCount - 1) Then p_Buttons(intCounter).PicID = intPicID End If End If Next ' Shift the last picture to the location of the one being deleted, then resize the array ' down by one to eliminate the last one... thus "deleting" the picture from the array ' without deleting the picture reference. Set p_Pictures(intPicID) = p_Pictures(p_PicturesCount - 1) p_PicturesCount = p_PicturesCount - 1 ReDim Preserve p_Pictures(0 To p_PicturesCount - 1) As StdPicture ' Set the current button's PicID property to indicate there's no picture assigned to it p_Buttons(intButtonID).PicID = -1 End If End If Else ' Set the current button's PicID property to indicate there's no picture assigned to it p_Buttons(intButtonID).PicID = -1 End If ' There is less than one picture in existance, so reset the array and count Else Erase p_Pictures p_PicturesCount = 0 p_Buttons(intButtonID).PicID = -1 End If End Sub