' C) Insert Mini Buttons, Combos and Checkbox on Each Categories
' D) Option to Show Menu Under the Ribbon and Hide Ribbon
' E) Make Menu
' F) Option to user customize the menu
' G) Group Tabs
' H) Add Comment to All code
' I) FINISHED this project!
'
'------------------------------------------------
'------------------------------------------------
' Bugs:
'
' Please report to:
'
' adrianopaladini@gmail.com
'
'------------------------------------------------
' enhancements done by Anele Mbanga (anelem@rocketmail.com) are the following
' the enhancement made include the following
' addition of textbox, combobox, datepicker, progress bar, label on buttons
' animation of main icon, see timer functions on form 1
' ability to edit the top button, edit the tab caption and button caption including icons thereof
' buttons now have menus that can be assigned to them
' buttons and tabs are no longer limited to 90 buttons, a redimensionable array has been used across the board
' menus, buttons can be added depending on the permissions per button, the permission string must contain the id of a button separated by ;
' if you like please vote for me
Private TotalTopButton As Integer
Private TotalButton As Integer
Private TotalTabs As Integer
Private TotalCats As Integer
Private Type TabButton
TabID As String
TabCaption As String
TabVisible As Boolean
End Type
Private TabButtons() As TabButton
Private Type CategoryButton
CatsID As String
CatsC As String
CatsT As String
CatsD As String
CatsTool As String
End Type
Private CategoryButtons() As CategoryButton
Private Type TopButton
TopBID As String
TopBC As String
End Type
Private TopButtons() As TopButton
'Private mvarHandle As Long
Private TabSelected As String
Private DefFont As StdFont
Private Type RibbonButton
TopBuID As String
TopBuS As String
TopBuC As String
TopBuI As Picture
TopBuT As String
TopBuG As Boolean
TopBuX As String
TopTxt As String
TopWdt As Long
TopType As String
TopFormat As String
TopMin As Long
TopMax As Long
menuName As String
End Type
Private sPermissions As String
Private RibbonButtons() As RibbonButton
'Private Type RECT
' Left As Long
'' Top As Long
'' Right As Long
' Bottom As Long
'End Type
Private MS As Boolean
Private Mx As Integer
Private My As Integer
Private iImgLType As Integer
Private sCaption As String
Private Const m_def_Caption = ""
Private Const m_def_ShowCustomMenu = False
Private m_ShowCustomMenu As Boolean
Private mvarUsePermissions As Boolean
Public Event MainMenuClick()
Public Event MenuClick(ByVal Id As String, ByVal Caption As String)
Public Event TabClick(ByVal Id As String, ByVal Caption As String)
Public Event CatClick(ByVal Id As String, ByVal Caption As String)
Public Event ButtonClick(ByVal Id As String, ByVal Caption As String)
Public Event ComboClick(ByVal ComboName As String, ByVal Text As String)
Public Event DatePickClick(ByVal DatePickName As String, ByVal DatePicked As String)
Public Event CustomClick()
Public Event CloseForm()
Public Event MaxForm()
Public Event MinForm()
Private zImg As Variant
Private TAB_NORMAL As Long
Private TAB_SELECTED As Long
Public Enum ThemeEnum
Black = 0
Blue = 1
Silver = 2
End Enum
Public Enum ImageSizeEnum
SizeNormal = 0
Size160 = 1
Size240 = 2
Size320 = 3
End Enum
Private m_Theme As ThemeEnum
Private m_ImageSize As Integer
Private mParent As Variant
'Private Const WM_SETREDRAW = &HB
'Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'Private Const RDW_INVALIDATE = &H1
'Private Const RDW_INTERNALPAINT = &H2
'Private Const RDW_UPDATENOW = &H100
'Private Const RDW_ALLCHILDREN = &H80
'Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Public Sub FreezeWindow(ObjSource As Variant, Optional boolAction As Boolean = True)
On Error Resume Next
If boolAction = True Then
LockWindowUpdate ObjSource.hwnd
Else
LockWindowUpdate 0&
End If
Err.Clear
End Sub
Private Sub Barra_DblClick()
On Error Resume Next
Maxon_Click
Err.Clear
End Sub
Private Sub Barra_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error Resume Next
Mx = x
My = y
MS = True
Err.Clear
End Sub
Private Sub Barra_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Property Let ShowCustomMenu(ByVal New_ShowCustomMenu As Boolean)
On Error Resume Next
m_ShowCustomMenu = New_ShowCustomMenu
PropertyChanged "ShowCustomMenu"
Err.Clear
End Property
Private Sub RibbonTopCustom_over_Click()
On Error Resume Next
RaiseEvent CustomClick
Err.Clear
End Sub
Public Sub AddButton(zID As String, zSubCat As String, zCaption As String, zPicture As Variant, zMore As Boolean, zToolTip As String, SplitCaption As Boolean)
On Error Resume Next
If UsePermissions = False Then GoTo AddIt
Dim strPrefix As String
Dim strSuffix As String
strPrefix = MvField(zID, 1, "_")
Select Case strPrefix
Case "openportfolio"
strSuffix = MvField(zID, -1, "-")
If IsNumeric(strSuffix) = True Then
Else
strSuffix = MvField(zID, 3, "_")
If MvSearch(Permissions, "openportfolio_" & strSuffix, ";") = 0 Then Exit Sub
End If
Case Else
If MvSearch(Permissions, zID, ";") = 0 Then Exit Sub
End Select
AddIt:
zCaption = ProperCase(zCaption)
If SplitCaption = True Then zCaption = Replace$(zCaption, " ", vbNewLine)
TotalButton = TotalButton + 1
ReDim Preserve RibbonButtons(TotalButton - 1)
RibbonButtons(TotalButton - 1).TopBuID = zID
RibbonButtons(TotalButton - 1).TopBuS = zSubCat
RibbonButtons(TotalButton - 1).TopBuC = zCaption
If Len(zToolTip) = 0 Or zToolTip = Null Then
If InStr(zCaption, vbNewLine) Then
zCaption = Replace$(zCaption, vbNewLine, " ")
End If
RibbonButtons(TotalButton - 1).TopBuT = zCaption
Else
zToolTip = Replace$(zToolTip, vbNewLine, " ")
RibbonButtons(TotalButton - 1).TopBuT = zToolTip
End If
Set RibbonButtons(TotalButton - 1).TopBuI = Nothing
If Len(zPicture) > 0 Then Set RibbonButtons(TotalButton - 1).TopBuI = zImg.ListImages.Item(GetIconIndex(zImg, zPicture)).Picture
RibbonButtons(TotalButton - 1).TopBuG = zMore
RibbonButtons(TotalButton - 1).TopTxt = ""
RibbonButtons(TotalButton - 1).TopWdt = 0
RibbonButtons(TotalButton - 1).TopType = ""
RibbonButtons(TotalButton - 1).TopFormat = ""
RibbonButtons(TotalButton - 1).TopBuX = ""
CatsUpdate
Err.Clear
End Sub
Public Sub AddComboBox(zID As String, zSubCat As String, zCaption As String, zToolTip As String, ByVal cboName As String, ByVal cboWidth As Long)
On Error Resume Next
If UsePermissions = False Then GoTo AddIt
Dim strPrefix As String
Dim strSuffix As String
strPrefix = MvField(zID, 1, "_")
Select Case strPrefix
Case "openportfolio"
strSuffix = MvField(zID, -1, "-")
If IsNumeric(strSuffix) = True Then
Else
strSuffix = MvField(zID, 3, "_")
If MvSearch(Permissions, "openportfolio_" & strSuffix, ";") = 0 Then Exit Sub
End If
Case Else
If MvSearch(Permissions, zID, ";") = 0 Then Exit Sub
End Select
AddIt:
zCaption = ProperCase(zCaption)
TotalButton = TotalButton + 1
ReDim Preserve RibbonButtons(TotalButton - 1)
RibbonButtons(TotalButton - 1).TopBuID = zID
RibbonButtons(TotalButton - 1).TopBuS = zSubCat
RibbonButtons(TotalButton - 1).TopBuC = zCaption
If Len(zToolTip) = 0 Or zToolTip = Null Then
If InStr(zCaption, vbNewLine) Then
zCaption = Replace$(zCaption, vbNewLine, " ")
End If
RibbonButtons(TotalButton - 1).TopBuT = zCaption
Else
zToolTip = Replace$(zToolTip, vbNewLine, " ")
RibbonButtons(TotalButton - 1).TopBuT = zToolTip
End If
Set RibbonButtons(TotalButton - 1).TopBuI = Nothing
RibbonButtons(TotalButton - 1).TopBuG = False
RibbonButtons(TotalButton - 1).TopTxt = cboName
RibbonButtons(TotalButton - 1).TopWdt = cboWidth
RibbonButtons(TotalButton - 1).TopType = "c"
RibbonButtons(TotalButton - 1).TopFormat = ""
CatsUpdate
Err.Clear
End Sub
Public Sub TabShow(ByVal zID As String)
On Error Resume Next
Dim myLocation As Integer
myLocation = TabSearch(zID)
If myLocation <> -1 Then
SaveSetting App.Title, "click", "tab", zID
TabButtons(myLocation).TabVisible = True
Me.Refresh
TabMouse_Click myLocation
End If
Err.Clear
End Sub
Public Sub TabHide(ByVal zID As String)
On Error Resume Next
Dim myLocation As Integer
myLocation = TabSearch(zID)
If myLocation <> -1 Then
TabButtons(myLocation).TabVisible = False
Me.Refresh
TabMouse_Click 0
End If
Err.Clear
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=14,0,0,0
'Public Property Get Theme() As ThemeEnum
'
' Theme = m_Theme
'
'End Property
Public Property Let Theme(ByVal New_Theme As ThemeEnum)
On Error Resume Next
'Freeze
m_Theme = New_Theme
PropertyChanged "Theme"
LoadTheme m_Theme
'Freeze False
Err.Clear
End Property
Public Sub LoadTheme(iTema As ThemeEnum)
On Error Resume Next
Dim Id As String
Select Case iTema
Case 0
Id = "BLACK"
Titulo.ForeColor = &HFFFFFF
Titulo2.ForeColor = &HFFD18A
Cat_Caption(0).ForeColor = &HFFFFFF
TAB_NORMAL = vbWhite
TAB_SELECTED = vbBlack
Button_Caption(0).ForeColor = &H80000008
Case 1
Id = "BLUE"
Titulo.ForeColor = &H797069
Titulo2.ForeColor = &HB86A3E
Cat_Caption(0).ForeColor = &HB86A3E
TAB_NORMAL = &H8B4215
TAB_SELECTED = &H8B4215
Button_Caption(0).ForeColor = &H8B4215
Case 2
Id = "SILVER"
Titulo.ForeColor = &H6A625C
Titulo2.ForeColor = &HB86A3E
Cat_Caption(0).ForeColor = &H6A625C
TAB_NORMAL = &H6A625C
TAB_SELECTED = &H6A625C
Button_Caption(0).ForeColor = &H6A625C
Case Else
Id = "BLACK"
End Select
Set Barra2.Picture = LoadResourcePicture(101, Id)
Set BarraLeft.Picture = LoadResourcePicture(102, Id)
Set BarraRight.Picture = LoadResourcePicture(103, Id)
Set Minoff.Picture = LoadResourcePicture(104, Id)
Set Minon.Picture = LoadResourcePicture(105, Id)
Set Maxoff.Picture = LoadResourcePicture(106, Id)
Set Maxon.Picture = LoadResourcePicture(107, Id)
Set Endoff.Picture = LoadResourcePicture(108, Id)
Set Endon.Picture = LoadResourcePicture(109, Id)
Set ButtonRibbonoff.Picture = LoadResourcePicture(110, Id)
Set ButtonRibbonover.Picture = LoadResourcePicture(111, Id)
Set ButtonRibbonon.Picture = LoadResourcePicture(112, Id)
Set RibbonTop.Picture = LoadResourcePicture(113, Id)
Set RibbonTopRight.Picture = LoadResourcePicture(114, Id)
Set RibbonTopCustom.Picture = LoadResourcePicture(115, Id)
Set RibbonTopCustom_over.Picture = LoadResourcePicture(116, Id)
Set RibbonTop_over(0).Picture = LoadResourcePicture(117, Id)
Set Cat_Dlg(0).Picture = LoadResourcePicture(118, Id)
Set Cat_Dlg_on(0).Picture = LoadResourcePicture(119, Id)
Set Cat_Dlg_over(0).Picture = LoadResourcePicture(120, Id)
Set Cat_Left_off(0).Picture = LoadResourcePicture(121, Id)
Set Cat_Center_off(0).Picture = LoadResourcePicture(122, Id)
Set Cat_Right_off(0).Picture = LoadResourcePicture(123, Id)
Set Cat_Left_on(0).Picture = LoadResourcePicture(124, Id)
Set Cat_Center_on(0).Picture = LoadResourcePicture(125, Id)
Set Cat_Right_on(0).Picture = LoadResourcePicture(126, Id)
Set Tab_left(0).Picture = LoadResourcePicture(127, Id)
Set Tab_center(0).Picture = LoadResourcePicture(128, Id)
Set Tab_right(0).Picture = LoadResourcePicture(129, Id)
Set Tab_left_over(0).Picture = LoadResourcePicture(130, Id)
Set Tab_center_over(0).Picture = LoadResourcePicture(131, Id)
Set Tab_right_over(0).Picture = LoadResourcePicture(132, Id)
Set Glip_off(0).Picture = LoadResourcePicture(133, Id)
Set Glip_on(0).Picture = LoadResourcePicture(134, Id)
Set Button_left_over(0).Picture = LoadResourcePicture(135, Id)
Set Button_center_over(0).Picture = LoadResourcePicture(136, Id)
Set Button_right_over(0).Picture = LoadResourcePicture(137, Id)
Set Button_left(0).Picture = LoadResourcePicture(138, Id)
Set Button_center(0).Picture = LoadResourcePicture(139, Id)
Set Button_right(0).Picture = LoadResourcePicture(140, Id)
Err.Clear
End Sub
Private Function TempFileName(ByVal strPrefix As String) As String
