My RibbonBar + ExplorerBar
My RibbonBar + ExplorerBar
Hi ! Antonio.. FWH is the Best.. I created OCX with VB.. then use in FWH
Friend's
Please vote my OCX :
http://www.mediafire.com/?sharekey=4e91 ... f6e8ebb871
Regards
Fafi,
Friend's
Please vote my OCX :
http://www.mediafire.com/?sharekey=4e91 ... f6e8ebb871
Regards
Fafi,
Last edited by fafi on Tue Apr 14, 2009 1:23 am, edited 3 times in total.
Re: My RibbonBar + ExplorerBar
Hello fafi,
I wanted to test Your application ( with Vista )
There was a problem ( didn't run, Vista-message : Main.exe doesn't work anymore ).
I compiled new and noticed my Exe (1.4 MB) was twice bigger than Yours ( 578 KB ) in the Zip-file.
After running the new Exe, nothing happend, but the prog. runs in memory.
To kill the task was not possible. The Task-manager doesn't show something.
For the moment I cannot reboot, but I will try again.
Maybe I have to use the latest xHarbour ?
Regards
Uwe
I wanted to test Your application ( with Vista )
There was a problem ( didn't run, Vista-message : Main.exe doesn't work anymore ).
I compiled new and noticed my Exe (1.4 MB) was twice bigger than Yours ( 578 KB ) in the Zip-file.
After running the new Exe, nothing happend, but the prog. runs in memory.
To kill the task was not possible. The Task-manager doesn't show something.
For the moment I cannot reboot, but I will try again.
Maybe I have to use the latest xHarbour ?
Regards
Uwe
Since 1995 ( the first release of FW 1.9 )
i work with FW.
If you have any questions about special functions, maybe i can help.
i work with FW.
If you have any questions about special functions, maybe i can help.
Re: My RibbonBar + ExplorerBar
Hi ! Uwe ..Thank's for your reportukoenig wrote:
I compiled new and noticed my Exe (1.4 MB) was twice bigger than Yours ( 578 KB ) in the Zip-file.
my main.exe packed by UPX
then recompile with
- xHarbour Compiler build 1.1.0 (SimpLex)
- BCC55
- FWH 8.05
the size 1.4 MB.. run ok with XP 2
Waiting for another vote..
Thank's
Fafi,
- Ricardo Ramirez E.
- Posts: 161
- Joined: Wed Jan 25, 2006 10:45 am
- Location: Praia - Cape Verde
- Contact:
Re: My RibbonBar + ExplorerBar
main.exe 1,873,408 bytes decompressed
Error In Windows Vista Failded
tks
Error In Windows Vista Failded
tks
Saludos
Ricardo R.
xHarbour 1.1.0 Simplex , Microsoft Visual Studio 2008, Bcc55, Fwh Build. 9.01
Ricardo R.
xHarbour 1.1.0 Simplex , Microsoft Visual Studio 2008, Bcc55, Fwh Build. 9.01
- Antonio Linares
- Site Admin
- Posts: 37481
- Joined: Thu Oct 06, 2005 5:47 pm
- Location: Spain
- Contact:
Re: My RibbonBar + ExplorerBar
Fafi,
This is very interesting!
Congratulations for this great and clever idea
Would you mind to explain how you have build those OCXs ? Is the RibbonBar a native VB control ?
Are you using a third party control for the Ribbonbar ? Are there any licence issues or are they really free ?
This is very interesting!
Congratulations for this great and clever idea
Would you mind to explain how you have build those OCXs ? Is the RibbonBar a native VB control ?
Are you using a third party control for the Ribbonbar ? Are there any licence issues or are they really free ?
Re: My RibbonBar + ExplorerBar
Hello fafi,
the new compiled exe-file I tested with WIN 2000, Vista and XP.
With XP it runs without Errors.
With WIN 2000 I get the following Error :
Runtime-Error 91 from ExplorerBar :
Object-Var or With-Blockvar not defined.
With Vista, nothing happens. The File is loaded without display.
Regards
Uwe
the new compiled exe-file I tested with WIN 2000, Vista and XP.
With XP it runs without Errors.
With WIN 2000 I get the following Error :
Runtime-Error 91 from ExplorerBar :
Object-Var or With-Blockvar not defined.
With Vista, nothing happens. The File is loaded without display.
Regards
Uwe
Since 1995 ( the first release of FW 1.9 )
i work with FW.
If you have any questions about special functions, maybe i can help.
i work with FW.
If you have any questions about special functions, maybe i can help.
Re: My RibbonBar + ExplorerBar
UWE, Ricardo thank's for vote
Pure VB Code, no third party, it's free, just for test my skill on vb, I used API below :
then for the control I used Image and Label with array
Antonio,
my problem is : I can't send FWH Imagelist to VB , to set this property Set TopBuI(TotalButton - 1) = LoadResPicture(nIcon, "CUSTOM")
as you know in VB there is control Imagelist below :
to call class from FWH = oAct:Do("Imagelist", with FWH Imagelist )
as you see in VB, the parameters ByVal zImageList As ImageList
I can't create this class on VB, cause don't know.. what's object type to instead Imagelist on VB, when I send Imagelist Object from FWH...
Can we create this RibbonBar with FWH CLASS together ?
Antonio,
If you don't mind, just teach me how to create class with FWH about :
Mouse Over, Mouse Move, Mouse Down, Mouse Up and How to call this :
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long with FWH.
Thank's for help
Regards
Fafi,
Antonio,Antonio Linares wrote:
Would you mind to explain how you have build those OCXs ? Is the RibbonBar a native VB control ?
Are you using a third party control for the Ribbonbar ? Are there any licence issues or are they really free ?
Pure VB Code, no third party, it's free, just for test my skill on vb, I used API below :
Code: Select all
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Code: Select all
Private Sub ButMouse_Click(Index As Integer)
On Error Resume Next
RaiseEvent ButtonClick(ButMouse(Index).Tag, Button_Caption(Index).Caption)
End Sub
Private Sub ButMouse_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Button_left_over(Index).Visible = True
Button_center_over(Index).Visible = True
Button_right_over(Index).Visible = True
End Sub
Private Sub ButMouse_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
TabNone
CatNone Button_center(Index).Tag
ButNone Index
End Sub
Private Sub ButMouse_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Button_left_over(Index).Visible = False
Button_center_over(Index).Visible = False
Button_right_over(Index).Visible = False
End Sub
my problem is : I can't send FWH Imagelist to VB , to set this property Set TopBuI(TotalButton - 1) = LoadResPicture(nIcon, "CUSTOM")
as you know in VB there is control Imagelist below :
Code: Select all
Dim zImg As ImageList
Set TopBuI(TotalButton - 1) = zImg.ListImages.Item(zPicture).Picture
Public Property Let ImageList(ByVal zImageList As ImageList)
Set zImg = zImageList
End Property
as you see in VB, the parameters ByVal zImageList As ImageList
I can't create this class on VB, cause don't know.. what's object type to instead Imagelist on VB, when I send Imagelist Object from FWH...
Can we create this RibbonBar with FWH CLASS together ?
Antonio,
If you don't mind, just teach me how to create class with FWH about :
Mouse Over, Mouse Move, Mouse Down, Mouse Up and How to call this :
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long with FWH.
Thank's for help
Regards
Fafi,
- Antonio Linares
- Site Admin
- Posts: 37481
- Joined: Thu Oct 06, 2005 5:47 pm
- Location: Spain
- Contact:
Re: My RibbonBar + ExplorerBar
Fafi,
oAct:SetProp( "Imagelist", oImageList:hImageList )
Try this:to call class from FWH = oAct:Do("Imagelist", with FWH Imagelist )
oAct:SetProp( "Imagelist", oImageList:hImageList )
yes Please post the VB code here or email it to me, and we will test it together. Thanks,Can we create this RibbonBar with FWH CLASS together ?
Are you using buttons for the RibbonBar Tabs ? I mean the tabs on the top of the control. Are they bitmaps ?If you don't mind, just teach me how to create class with FWH about :
Mouse Over, Mouse Move, Mouse Down, Mouse Up and How to call this :
FWH provides GetWindowLong() with same parametersPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long with FWH.
Re: My RibbonBar + ExplorerBar
Antonio,
1. ImageLeft
2. ImageCenter
3. ImageRight
FWH can do it with oBitmap ( ABPaint )
then for check MouseEvent, I used Label
FWH can do it with oSay
Antonio,
I have StyleButton also :
here is my ocx : http://www.veteranclipper.com/StyleButton.rar
Yes ! I added Images to usercontrol, about 3 images for each one tab :Are you using buttons for the RibbonBar Tabs ? I mean the tabs on the top of the control. Are they bitmaps ?
1. ImageLeft
2. ImageCenter
3. ImageRight
FWH can do it with oBitmap ( ABPaint )
then for check MouseEvent, I used Label
FWH can do it with oSay
I prefer to email you..Please post the VB code here or email it to me, and we will test it together. Thanks,
Antonio,
I have StyleButton also :
here is my ocx : http://www.veteranclipper.com/StyleButton.rar
Code: Select all
/*
My OCX create with VB
by Fafi
*/
#include "FiveWin.ch"
static oGetEvent,cGetEvent,oWnd,oBrushSilver,oBrushBlack,oBrushBlue,oAct1,oAct2,oAct
function Main()
RegisterServer( "StyleButton.ocx" )
RegisterServer( "FafiXPBar.ocx" )
RegisterServer( "FafiXRBar.ocx" )
cGetEvent := ""+CRLF
DEFINE FONT oFont NAME "Tahoma" size 0,-32 BOLD
DEFINE ICON oIcon NAME "BASEPRO"
DEFINE BRUSH oBrushSilver COLOR nRGB(208,212,221)
DEFINE BRUSH oBrushBlack COLOR nRGB(83,83,83)
DEFINE BRUSH oBrushBlue COLOR nRGB(142,176,218)
DEFINE WINDOW oWnd TITLE "FWH Support Fafi OCX" MENU BuildMenu() BRUSH oBrushSilver ICON oIcon
define dialog oDlg from 120,202 to 742,1600 pixel of oWnd style nOR( WS_VISIBLE, WS_CHILD ) BRUSH oBrushBlue transparent
@70,150 say "Hi ! Antonio.. FWH is the Best for ActiveX Support.. I Created OCX with VB.. then use in FWH" size 300,200 of oDlg pixel font oFont color CLR_YELLOW
@70,10 say "Hello Event " size 60,12 of oDlg pixel
@80,10 get oGetEvent var cGetEvent size 120,200 of oDlg pixel memo
// nTop, nLeft. nWidth, nHeight
oAct2 := TActiveX():New( oWnd, "FafiButton.StylerButton", 130, 220, 350, 100 )
oAct2:SetProp("Caption","Fafi Button")
oAct3 := TActiveX():New( oWnd, "FafiButton.StylerButton", 130, 600, 350, 100 )
oAct3:SetProp("Caption","Fivewin 8.05")
oAct3:SetProp("RoundedValue",20)
oAct3:SetProp("FocusDottedRect",.f.)
oAct2:SetProp("FocusDottedRect",.f.)
oFontButton := TOleAuto():New( ActXPdisp( oAct3:hActiveX ) )
oFontButton := oFontButton:Font()
oFontButton:Size := 48
oFontButton:Name := "Times New Roman"
oFontButton := TOleAuto():New( ActXPdisp( oAct2:hActiveX ) )
oFontButton := oFontButton:Font()
oFontButton:Size := 48
oFontButton:Name := "Times New Roman"
oAct2:bOnEvent := { | cEvent, aParams, pParams | ButtonEvent( cEvent, aParams, pParams ) }
oAct3:bOnEvent := { | cEvent, aParams, pParams | ButtonEvent( cEvent, aParams, pParams ) }
oAct1 := TActiveX():New( oWnd, "FafiOCX.RibbonBar", 0, 0, 1800, 120 )
oAct1:bOnEvent := { | cEvent, aParams, pParams | RibbonEvent( cEvent, aParams, pParams ) }
oAct1:SetProp("Theme",2)
oAct1:do("AddTab", "1", "Effect")
oAct1:do("AddTab", "2", "Tab 2" )
oAct1:do("AddTab", "3", "Sample Tab")
oAct1:do("AddTab", "4", "New Tab")
oAct1:do("AddTab", "5", "Print")
oAct1:do("AddTab", "6", "Exit")
oAct1:do("Refresh")
oAct1:do("AddCat" , "1", "1", "Please select Effect Button", .f.)
oAct1:do("AddButton", "1", "1", " SILVER ", 501 )
oAct1:do("AddButton", "2", "1", " BLACK ", 5 )
oAct1:do("AddButton", "3", "1", " BLUE ", 5 )
oAct1:do("Refresh")
oAct := TActiveX():New( oWnd, "FafiOCX.ExpBar", 120, 0, 200, 578 )
oAct:Do("AddSpecialItem","File")
oAct:Do("AddSubItem", 1, "Open")
oAct:Do("AddSubItem", 1, "Close")
oAct:Do("AddSpecialItem","Print")
oAct:Do("AddSubItem", 2, "Setup")
oAct:Do("AddSubItem", 2, "Preview")
oAct:Do("AddSpecialItem","Event")
oAct:Do("AddSubItem", 3, "Clear Event")
oAct:Do("AddSpecialItem","Change Fafi Button Theme")
oAct:Do("AddSubItem", 4, "Media Center Edition")
oAct:Do("AddSubItem", 4, "Media Player 11")
oAct:Do("AddSubItem", 4, "Office 2007 1")
oAct:Do("AddSubItem", 4, "Office 2007 2")
oAct:Do("AddSubItem", 4, "Vista 1")
oAct:Do("AddSubItem", 4, "Vista 2")
oAct:Do("AddSubItem", 4, "XP Blue")
oAct:Do("AddSubItem", 4, "XP Olive Green")
oAct:Do("AddSubItem", 4, "XP Silver")
//oAct:Do("AddSpecialItem","Change Fafi Button Style")
//oAct:Do("AddSubItem", 5, "Normal")
//oAct:Do("AddSubItem", 5, "Round")
//oAct:Do("AddSubItem", 5, "More Round")
oAct:bOnEvent := { | cEvent, aParams, pParams | ExplorerBarEvent( cEvent, aParams, pParams ) }
activate dialog oDlg nowait
SET MESSAGE OF oWnd TO "Ready" NOINSET CLOCK DATE KEYBOARD 2007
ACTIVATE WINDOW oWnd MAXIMIZED
return nil
static function ExplorerBarEvent( cEvent, aParams, pParams )
cEvent := upper(alltrim(cEvent))
if left(cEvent,5) == "MOUSE" // don't use mouse event
else
cGetEvent += cEvent + CRLF
endif
do case
case cEvent == "SUBITEMCLICK"
cGetEvent += alltrim(oAct:do("SubItem",aParams[1],aParams[2]))+CRLF
if upper(alltrim(oAct:do("SubItem",aParams[1],aParams[2]))) == "CLEAR EVENT"
cGetEvent := ""+CRLF
endif
if upper(alltrim(oAct:do("SubItem",aParams[1],aParams[2]))) == upper("Media Center Edition")
oAct2:SetProp("Theme",1)
oAct3:SetProp("Theme",1)
endif
if upper(alltrim(oAct:do("SubItem",aParams[1],aParams[2]))) == upper("Media Player 11")
oAct2:SetProp("Theme",2)
oAct3:SetProp("Theme",2)
endif
if upper(alltrim(oAct:do("SubItem",aParams[1],aParams[2]))) == upper("Office 2007 1")
oAct2:SetProp("Theme",3)
oAct3:SetProp("Theme",3)
endif
if upper(alltrim(oAct:do("SubItem",aParams[1],aParams[2]))) == upper("Office 2007 2")
oAct2:SetProp("Theme",4)
oAct3:SetProp("Theme",4)
endif
if upper(alltrim(oAct:do("SubItem",aParams[1],aParams[2]))) == upper("Vista 1")
oAct2:SetProp("Theme",5)
oAct3:SetProp("Theme",5)
endif
if upper(alltrim(oAct:do("SubItem",aParams[1],aParams[2]))) == upper("Vista 2")
oAct2:SetProp("Theme",6)
oAct3:SetProp("Theme",6)
endif
if upper(alltrim(oAct:do("SubItem",aParams[1],aParams[2]))) == upper("XP Blue")
oAct2:SetProp("Theme",7)
oAct3:SetProp("Theme",7)
endif
if upper(alltrim(oAct:do("SubItem",aParams[1],aParams[2]))) == upper("XP Olive Green")
oAct2:SetProp("Theme",8)
oAct3:SetProp("Theme",8)
endif
if upper(alltrim(oAct:do("SubItem",aParams[1],aParams[2]))) == upper("XP Silver")
oAct2:SetProp("Theme",9)
oAct3:SetProp("Theme",9)
endif
endcase
oGetEvent:Refresh()
return nil
static function RibbonEvent( cEvent, aParams, pParams )
cEvent := upper(alltrim(cEvent))
if left(cEvent,5) == "MOUSE" // don't use mouse event
else
cGetEvent += cEvent + CRLF
endif
do case
case cEvent == "TABCLICK"
cGetEvent += aParams[2]+ CRLF
if upper(alltrim(aParams[2])) == "EXIT"
if MsgYesNo("Want to Exit ?")
oWnd:End()
endif
endif
case cEvent == "BUTTONCLICK"
cGetEvent += aParams[2]+ CRLF
cAction := upper(alltrim(aParams[2]))
if cAction == "DIALOG"
Dlg()
endif
if cAction == "BLUE"
oWnd:oBrush := oBrushBlue
oWnd:Refresh()
oAct1:SetProp("Theme",1)
oAct1:do("refresh")
endif
if cAction == "BLACK"
oWnd:oBrush := oBrushBlack
oWnd:Refresh()
oAct1:SetProp("Theme",0)
oAct1:do("refresh")
endif
if cAction == "SILVER"
oWnd:oBrush := oBrushSilver
oWnd:Refresh()
oAct1:SetProp("Theme",2)
oAct1:do("refresh")
endif
if upper(alltrim(aParams[2])) == ""
cGetEvent := "Event : "+CRLF
endif
endcase
oGetEvent:Refresh()
return nil
static function ButtonEvent( cEvent, aParams, pParams )
cEvent := upper(alltrim(cEvent))
if left(cEvent,5) == "MOUSE" // don't use mouse event
else
cGetEvent += cEvent + CRLF
endif
if cEvent == "CLICK"
cGetEvent += aParams[1]+ CRLF
endif
oGetEvent:Refresh()
return nil
static function ButtonEvent3( cEvent, aParams, pParams )
cEvent := upper(alltrim(cEvent))
if left(cEvent,5) == "MOUSE" // don't use mouse event
else
cGetEvent += cEvent + CRLF
endif
if cEvent == "CLICK"
cGetEvent += aParams[1]+ CRLF
endif
oGetEvent:Refresh()
return nil
FUNCTION BuildMenu()
local oMenu, oMenu1, oMenu2
local oSub1,oSub2,oSub3
MENU oMenu 2007
MENUITEM oMenu1 PROMPT "Test &1"
MENU
MENUITEM oSub1 PROMPT "Subject&1" CHECKED
/*
MENU
MENUITEM "Choice 1"
MENUITEM "Choice 2"
MENUITEM "Choice 3"
ENDMENU */
MENUITEM "Subject&2"
MENU
MENUITEM "Option 1"
MENUITEM "Option 2"
MENUITEM "Option 3"
MENU
MENUITEM "Selection 1"
MENUITEM "Selection 2"
MENUITEM "Selection 3"
MENU
MENUITEM "Sub-selection 1"
MENUITEM "Sub-selection 2"
MENU
MENUITEM "Sub-sub-selection 1"
MENUITEM "Sub-sub-selection 2"
MENUITEM "Sub-sub-selection 3"
MENU
MENUITEM "Lowest level 1"
MENUITEM "Lowest level 2"
ENDMENU
ENDMENU
ENDMENU
MENUITEM "Selection 4"
ENDMENU
ENDMENU
MENUITEM "Toggle Subject 1 Check" ACTION oSub1:SetCheck( ! oSub1:lChecked )
ENDMENU
MENUITEM "Test 2"
MENU
MENUITEM "Item 1"
MENUITEM "Item 2"
ENDMENU
ENDMENU
// oMenu2:Disable()
RETURN (oMenu)
static function Dlg()
define dialog oDlg from 1,1 to 600,800 pixel of oWnd
activate dialog oDlg centered
return nil
#pragma BEGINDUMP
#include <hbapi.h>
#include <windows.h>
typedef LONG ( * PDLLREGISTERSERVER ) ( void );
HB_FUNC( REGISTERSERVER )
{
HMODULE hDll = LoadLibrary( hb_parc( 1 ) );
LONG lReturn = 0;
if( hDll )
{
FARPROC pRegisterServer = GetProcAddress( hDll, "DllRegisterServer" );
if( pRegisterServer )
lReturn = ( ( PDLLREGISTERSERVER ) pRegisterServer )();
FreeLibrary( hDll );
}
hb_retnl( lReturn );
}
#pragma ENDDUMP
- Antonio Linares
- Site Admin
- Posts: 37481
- Joined: Thu Oct 06, 2005 5:47 pm
- Location: Spain
- Contact:
Re: My RibbonBar + ExplorerBar
Fafi,
ok, I wait for your email
Do you use VB Express ?
ok, I wait for your email
Do you use VB Express ?
Re: My RibbonBar + ExplorerBar
Antonio,
>> ok, I wait for your email
Your email please ..
>> Do you use VB Express ?
I used VB 6
Regards
Fafi
>> ok, I wait for your email
Your email please ..
>> Do you use VB Express ?
I used VB 6
Regards
Fafi
- Antonio Linares
- Site Admin
- Posts: 37481
- Joined: Thu Oct 06, 2005 5:47 pm
- Location: Spain
- Contact:
Re: My RibbonBar + ExplorerBar
Fafi,
Before you email me anything, please consider that I would like to publically explain here how to build an OCX using VB that can be used from FWH.
I don't want any troubles about this. So if you don't want to share your code or ideas, then please don't email it to me. I hope that you understand me, Thanks
Before you email me anything, please consider that I would like to publically explain here how to build an OCX using VB that can be used from FWH.
I don't want any troubles about this. So if you don't want to share your code or ideas, then please don't email it to me. I hope that you understand me, Thanks
Re: My RibbonBar + ExplorerBar
Antonio,
Ok.. no problem Sir !
Here is :
Regards
Fafi
Ok.. no problem Sir !
Here is :
Code: Select all
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH = 260
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Dim TotalButton As Integer
Dim TotalTabs As Integer
Dim TotalCats As Integer
Dim TabSelected As String
Dim TabID(30) As String
Dim TabC(30) As String
Dim CatsID(30) As String
Dim CatsC(30) As String
Dim CatsT(30) As String
Dim CatsD(30) As Boolean
Dim TopBuID(90) As String
Dim TopBuS(90) As String
Dim TopBuC(90) As String
Dim TopBuI(90) As Picture
Dim TopBuT(90) As String
Dim TopBuG(90) As Boolean
Dim MS As Boolean
Dim Mx, My As Integer
Event TabClick(ByVal ID As String, ByVal Caption As String)
Event CatClick(ByVal ID As String, ByVal Caption As String)
Event ButtonClick(ByVal ID As String, ByVal Caption As String)
Const m_def_Theme = 0
Const m_def_BC = False
Dim m_Theme As Variant
Dim m_BC As Boolean
Dim zImg As ImageList
Dim TAB_NORMAL
Dim TAB_SELECTED
Private Sub TabNone(Optional Index As Integer = -1)
If Index <> -1 Then
For i = 0 To Index - 1
If Tab_center_over(i).Visible = True Then
Tab_center_over(i).Visible = False
Tab_left_over(i).Visible = False
Tab_right_over(i).Visible = False
End If
Next
If Tab_center(Index).Visible = False Then
Tab_center_over(Index).Visible = True
Tab_left_over(Index).Visible = True
Tab_right_over(Index).Visible = True
End If
For i = Index + 1 To TabMouse.UBound
If Tab_center_over(i).Visible = True Then
Tab_center_over(i).Visible = False
Tab_left_over(i).Visible = False
Tab_right_over(i).Visible = False
End If
Next
Else
For i = 0 To TabMouse.UBound
If Tab_center_over(i).Visible = True Then
Tab_center_over(i).Visible = False
Tab_left_over(i).Visible = False
Tab_right_over(i).Visible = False
End If
Next
End If
End Sub
Private Sub CatNone(Optional Index As Integer = -1)
If Index <> -1 Then
For i = 0 To Index - 1
If Cat_Center_on(i).Visible = True Then
Cat_Center_on(i).Visible = False
Cat_Left_on(i).Visible = False
Cat_Right_on(i).Visible = False
If Cat_Dlg(i).Visible = True Then
Cat_Dlg_on(i).Visible = False
Cat_Dlg_over(i).Visible = False
End If
End If
Next
Cat_Center_on(Index).Visible = True
Cat_Left_on(Index).Visible = True
Cat_Right_on(Index).Visible = True
If Cat_Dlg(Index).Visible = True Then
Cat_Dlg_on(Index).Visible = True
Cat_Dlg_over(Index).Visible = False
End If
For i = Index + 1 To CatMouse.UBound
If Cat_Center_on(i).Visible = True Then
Cat_Center_on(i).Visible = False
Cat_Left_on(i).Visible = False
Cat_Right_on(i).Visible = False
If Cat_Dlg(i).Visible = True Then
Cat_Dlg_on(i).Visible = False
Cat_Dlg_over(i).Visible = False
End If
End If
Next
Else
For i = 0 To CatMouse.UBound
If Cat_Center_on(i).Visible = True Then
Cat_Center_on(i).Visible = False
Cat_Left_on(i).Visible = False
Cat_Right_on(i).Visible = False
If Cat_Dlg(i).Visible = True Then
Cat_Dlg_on(i).Visible = False
Cat_Dlg_over(i).Visible = False
End If
End If
Next
End If
End Sub
Private Sub ButNone(Optional Index As Integer = -1)
If Index <> -1 Then
For KL = 0 To Index - 1
If Button_center(KL).Visible = True Then
Button_left(KL).Visible = False
Button_right(KL).Visible = False
Button_center(KL).Visible = False
If Glip_off(i).Visible = True Then
Glip_on(i).Visible = False
End If
End If
Next
If Button_left(Index).Visible = False Then
Button_left(Index).Visible = True
Button_center(Index).Visible = True
Button_right(Index).Visible = True
If Glip_off(Index).Visible = True Then
Glip_on(Index).Visible = True
End If
End If
For KL = Index + 1 To ButMouse.UBound
If Button_center(KL).Visible = True Then
Button_left(KL).Visible = False
Button_right(KL).Visible = False
Button_center(KL).Visible = False
If Glip_off(i).Visible = True Then
Glip_on(i).Visible = False
End If
End If
Next
Else
For KL = 0 To ButMouse.UBound
If Button_center(KL).Visible = True Then
Button_left(KL).Visible = False
Button_right(KL).Visible = False
Button_center(KL).Visible = False
If Glip_off(i).Visible = True Then
Glip_on(i).Visible = False
End If
End If
Next
End If
End Sub
Private Sub Barra2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
TabNone
CatNone
ButNone
End Sub
Private Sub BarraLeft_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
TabNone
CatNone
ButNone
End Sub
Private Sub BarraRight_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
TabNone
CatNone
ButNone
End Sub
Private Sub ButMouse_Click(Index As Integer)
RaiseEvent ButtonClick(ButMouse(Index).Tag, Button_Caption(Index).Caption)
End Sub
Private Sub ButMouse_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Button_left_over(Index).Visible = True
Button_center_over(Index).Visible = True
Button_right_over(Index).Visible = True
End Sub
Private Sub ButMouse_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
TabNone
CatNone Button_center(Index).Tag
ButNone Index
End Sub
Private Sub ButMouse_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Button_left_over(Index).Visible = False
Button_center_over(Index).Visible = False
Button_right_over(Index).Visible = False
End Sub
Private Sub Cat_Dlg_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
TabNone
CatNone Index
ButNone
End Sub
Private Sub Cat_Dlg_on_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
TabNone
CatNone Index
ButNone
Cat_Dlg_over(Index).Visible = True
End Sub
Private Sub Cat_Dlg_over_Click(Index As Integer)
RaiseEvent CatClick(Cat_Caption(Index).Tag, Cat_Caption(Index).Caption)
End Sub
Private Sub CatMouse_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
TabNone
CatNone Index
ButNone
End Sub
Private Sub TabMouse_Click(Index As Integer)
TabNone
For i = 0 To Index - 1
Tab_center(i).Visible = False
Tab_left(i).Visible = False
Tab_right(i).Visible = False
Tab_caption(i).ForeColor = TAB_NORMAL
Next
Tab_caption(Index).ForeColor = TAB_SELECTED
Tab_center(Index).Visible = True
Tab_left(Index).Visible = True
Tab_right(Index).Visible = True
For i = Index + 1 To TabMouse.UBound
Tab_center(i).Visible = False
Tab_left(i).Visible = False
Tab_right(i).Visible = False
Tab_caption(i).ForeColor = TAB_NORMAL
Next
TabSelected = TabID(Index)
CatsUpdate
RaiseEvent TabClick(TabID(Index), TabC(Index))
End Sub
Private Sub TabMouse_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
TabNone Index
CatNone
ButNone
End Sub
Private Sub UserControl_Initialize()
Barra2.Top = -(26 * 15)
BarraLeft.Top = Barra2.Top
BarraRight.Top = Barra2.Top
UserControl.Height = Barra2.Height
Barra2.Width = 2048 * 15
TotalTopButton = 0
TotalButton = 0
TotalTabs = 0
TotalCats = 0
TabSelected = ""
TabMouse(0).BackStyle = 0
CatMouse(0).BackStyle = 0
ButMouse(0).BackStyle = 0
End Sub
Private Sub TabsUpdate()
On Error Resume Next
For i = 1 To (TotalTabs - 1)
Unload Tab_caption(i)
Unload Tab_left(i)
Unload Tab_center(i)
Unload Tab_right(i)
Unload Tab_left_over(i)
Unload Tab_center_over(i)
Unload Tab_right_over(i)
Unload TabMouse(i)
Next
For i = 0 To (TotalTabs - 1)
If i <> 0 Then
Load Tab_caption(i)
Load Tab_left(i)
Load Tab_center(i)
Load Tab_right(i)
Load Tab_left_over(i)
Load Tab_center_over(i)
Load Tab_right_over(i)
Load TabMouse(i)
Tab_left(i).Left = Tab_right(i - 1).Left + Tab_right(i).Width
Else
Tab_left(0).Left = 90
End If
TabMouse(i).Left = Tab_left(i).Left
Tab_caption(i).Top = 0 + 60
Tab_center(i).Top = 0
Tab_left(i).Top = 0
Tab_right(i).Top = 0
Tab_center_over(i).Top = 0
Tab_left_over(i).Top = 0
Tab_right_over(i).Top = 0
TabMouse(i).Top = 0
Tab_caption(i) = TabC(i)
Tab_center(i).Width = Tab_caption(i).Width
Tab_center(i).Left = Tab_left(i).Left + Tab_left(i).Width
Tab_caption(i).Left = Tab_center(i).Left
Tab_right(i).Left = Tab_center(i).Left + Tab_center(i).Width
Tab_center_over(i).Width = Tab_center(i).Width
Tab_center_over(i).Left = Tab_center(i).Left
Tab_left_over(i).Left = Tab_left(i).Left
Tab_right_over(i).Left = Tab_right(i).Left
TabMouse(i).Width = Tab_left(i).Width + Tab_right(i).Width + Tab_center(i).Width
Tab_caption(i).ForeColor = TAB_NORMAL
Tab_caption(i).Visible = True
If i = 0 Then
Tab_center(i).Visible = True
Tab_left(i).Visible = True
Tab_right(i).Visible = True
Tab_caption(i).ForeColor = TAB_SELECTED
End If
TabMouse(i).Visible = True
Tab_center(i).ZOrder 0
Tab_left(i).ZOrder 0
Tab_right(i).ZOrder 0
Tab_center_over(i).ZOrder 0
Tab_left_over(i).ZOrder 0
Tab_right_over(i).ZOrder 0
Tab_caption(i).ZOrder 0
TabMouse(i).ZOrder 0
Next
End Sub
Private Sub CatsUpdate()
On Error Resume Next
ztopo = 360
Cat_Center_off(0).Top = ztopo
Cat_Center_on(0).Top = ztopo
Cat_Left_off(0).Top = ztopo
Cat_Left_on(0).Top = ztopo
Cat_Right_off(0).Top = ztopo
Cat_Right_on(0).Top = ztopo
CatMouse(0).Top = ztopo
Cat_Caption(0).Top = 1400
Dim TotalCatsT As Integer
Dim CatsIDT(30) As String
Dim CatsCT(30) As String
Dim CatsTT(30) As String
Dim CatsDT(30) As Boolean
TotalCatsT = 0
For i = 0 To TotalCats
If CatsT(i) = TabSelected And TabSelected <> "" And CatsT(i) <> "" Then
CatsIDT(TotalCatsT) = CatsID(i)
CatsTT(TotalCatsT) = CatsT(i)
CatsCT(TotalCatsT) = CatsC(i)
CatsDT(TotalCatsT) = CatsD(i)
TotalCatsT = TotalCatsT + 1
End If
Next
For i = 1 To CatMouse.UBound
Unload Cat_Left_off(i)
Unload Cat_Left_on(i)
Unload Cat_Right_off(i)
Unload Cat_Right_on(i)
Unload Cat_Center_off(i)
Unload Cat_Center_on(i)
Unload Cat_Caption(i)
Unload CatMouse(i)
Unload Cat_Dlg(i)
Unload Cat_Dlg_on(i)
Unload Cat_Dlg_over(i)
Next
For i = 1 To Button_center.UBound
Unload Button_left(i)
Unload Button_center(i)
Unload Button_right(i)
Unload Button_left_over(i)
Unload Button_center_over(i)
Unload Button_right_over(i)
Unload Button_Caption(i)
Unload Button_Icon(i)
Unload Glip_on(i)
Unload Glip_off(i)
Unload ButMouse(i)
Next
Button_left(0).Visible = False
Button_center(0).Visible = False
Button_right(0).Visible = False
Button_Caption(0).Visible = False
Button_Icon(0).Visible = False
ButMouse(0).Visible = False
Cat_Left_off(0).Visible = False
Cat_Left_on(0).Visible = False
Cat_Right_off(0).Visible = False
Cat_Right_on(0).Visible = False
Cat_Center_off(0).Visible = False
Cat_Center_on(0).Visible = False
Cat_Caption(0).Visible = False
CatMouse(0).Visible = False
Cat_Dlg(0).Visible = False
Cat_Dlg_on(0).Visible = False
Cat_Dlg_over(0).Visible = False
For i = 0 To (TotalCatsT - 1)
If i <> 0 Then
Load Cat_Left_off(i)
Load Cat_Left_on(i)
Load Cat_Right_off(i)
Load Cat_Right_on(i)
Load Cat_Center_off(i)
Load Cat_Center_on(i)
Load Cat_Caption(i)
Load CatMouse(i)
Load Cat_Dlg(i)
Load Cat_Dlg_on(i)
Load Cat_Dlg_over(i)
Cat_Left_off(i).Left = Cat_Right_off(i - 1).Left + Cat_Right_off(i).Width
Else
Cat_Left_off(i).Left = 120
End If
CatMouse(i).Left = Cat_Left_off(i).Left
Cat_Caption(i).Caption = CatsCT(i)
Cat_Caption(i).Tag = CatsIDT(i)
Cat_Center_off(i).Left = Cat_Left_off(i).Left + Cat_Left_off(i).Width
BUTSIZE = ButtonsUpdate(CatsIDT(i), Cat_Center_off(i).Left, i + 0)
If CatsDT(i) = True Then
Cat_Center_off(i).Width = Cat_Caption(i).Width + Cat_Dlg(i).Width
Else
Cat_Center_off(i).Width = Cat_Caption(i).Width
End If
If Cat_Center_off(i).Width < BUTSIZE Then
Cat_Center_off(i).Width = BUTSIZE
Cat_Caption(i).Left = Cat_Center_off(i).Left + ((Cat_Center_off(i).Width - Cat_Caption(i).Width) / 2)
Else
Cat_Caption(i).Left = Cat_Center_off(i).Left
End If
Cat_Right_off(i).Left = Cat_Center_off(i).Left + Cat_Center_off(i).Width
Cat_Center_on(i).Width = Cat_Center_off(i).Width
Cat_Center_on(i).Left = Cat_Center_off(i).Left
Cat_Left_on(i).Left = Cat_Left_off(i).Left
Cat_Right_on(i).Left = Cat_Right_off(i).Left
CatMouse(i).Width = Cat_Left_off(i).Width + Cat_Right_off(i).Width + Cat_Center_off(i).Width
Cat_Caption(i).Visible = True
Cat_Center_off(i).Visible = True
Cat_Left_off(i).Visible = True
Cat_Right_off(i).Visible = True
CatMouse(i).Visible = True
Cat_Center_off(i).ZOrder 0
Cat_Left_off(i).ZOrder 0
Cat_Right_off(i).ZOrder 0
Cat_Center_on(i).ZOrder 0
Cat_Left_on(i).ZOrder 0
Cat_Right_on(i).ZOrder 0
Cat_Caption(i).ZOrder 0
CatMouse(i).ZOrder 0
Cat_Dlg(i).Left = (Cat_Right_off(i).Left - Cat_Dlg(i).Width) + 15
Cat_Dlg(i).Top = (Cat_Right_off(i).Top + Cat_Right_off(i).Height) - (Cat_Dlg(i).Height + 60)
Cat_Dlg_on(i).Left = Cat_Dlg(i).Left
Cat_Dlg_over(i).Left = Cat_Dlg(i).Left
Cat_Dlg_on(i).Top = Cat_Dlg(i).Top
Cat_Dlg_over(i).Top = Cat_Dlg(i).Top
Cat_Dlg_on(i).Visible = False
Cat_Dlg_over(i).Visible = False
If CatsDT(i) = True Then
Cat_Dlg(i).Visible = True
End If
Cat_Dlg(i).ZOrder 0
Cat_Dlg_on(i).ZOrder 0
Cat_Dlg_over(i).ZOrder 0
Next
DoEvents
For KL = 0 To ButMouse.UBound
Button_left(KL).Visible = False
Button_left(KL).ZOrder 0
Button_right(KL).Visible = False
Button_right(KL).ZOrder 0
Button_center(KL).Visible = False
Button_center(KL).ZOrder 0
Button_left_over(KL).Visible = False
Button_left_over(KL).ZOrder 0
Button_right_over(KL).Visible = False
Button_right_over(KL).ZOrder 0
Button_center_over(KL).Visible = False
Button_center_over(KL).ZOrder 0
Button_Icon(KL).ZOrder 0
Button_Caption(KL).ZOrder 0
Glip_off(KL).ZOrder 0
Glip_on(KL).ZOrder 0
ButMouse(KL).ZOrder 0
Next
End Sub
Private Sub UserControl_Resize()
'On Error Resume Next
UserControl.Height = Barra2.Height - (26 * 15)
'UserControl.Width = UserControl.ParentControls.Item(0).ScaleWidth
'BarraRight.Left = UserControl.Width - BarraRight.Width
End Sub
Public Sub Refresh()
UserControl_Resize
TabsUpdate
CatsUpdate
End Sub
Private Sub UserControl_InitProperties()
m_Theme = m_def_Theme
m_BC = m_def_BC
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_Theme = PropBag.ReadProperty("Theme", m_def_Theme)
m_BC = PropBag.ReadProperty("ButtonCenter", m_def_BC)
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("Theme", m_Theme, m_def_Theme)
Call PropBag.WriteProperty("ButtonCenter", m_BC, m_def_BC)
Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H464646)
Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &HFFFFFF)
End Sub
Public Function AddTab(zID As String, zCaption As String) As Boolean
TotalTabs = TotalTabs + 1
TabID(TotalTabs - 1) = zID
zCaption = Replace(zCaption, vbNewLine, " ")
TabC(TotalTabs - 1) = zCaption
If TabSelected = "" Then
TabSelected = zID
End If
End Function
Public Function AddCat(zID As String, zTab As String, zCaption As String, zDlgButton As Boolean) As Boolean
TotalCats = TotalCats + 1
CatsID(TotalCats - 1) = zID
CatsT(TotalCats - 1) = zTab
zCaption = Replace(zCaption, vbNewLine, " ")
CatsC(TotalCats - 1) = zCaption
CatsD(TotalCats - 1) = zDlgButton
End Function
Public Function AddButton(zID As String, zSubCat As String, zCaption As String, zPicture As Integer, Optional zMore As Boolean = False, Optional zToolTip As String) As Boolean
TotalButton = TotalButton + 1
TopBuID(TotalButton - 1) = zID
TopBuS(TotalButton - 1) = zSubCat
TopBuC(TotalButton - 1) = zCaption
If zToolTip = "" Or zToolTip = Null Then
If InStr(zCaption, vbNewLine) Then
zCaption = Replace(zCaption, vbNewLine, " ")
End If
TopBuT(TotalButton - 1) = zCaption
Else
zToolTip = Replace(zToolTip, vbNewLine, " ")
TopBuT(TotalButton - 1) = zToolTip
End If
Set TopBuI(TotalButton - 1) = zImg.ListImages.Item(zPicture).Picture
TopBuG(TotalButton - 1) = zMore
End Function
Private Function ButtonsUpdate(SubCat As String, PosIni As Integer, CatID As Integer) As Integer
On Error Resume Next
Dim TotalButtonT As Integer
Dim TopBuIDT(90) As String
Dim TopBuST(90) As String
Dim TopBuCT(90) As String
Dim TopBuIT(90) As Picture
Dim TopBuTT(90) As String
Dim TopBuGT(90) As Boolean
TotalSize = 0
TotalButtonT = 0
For i = 0 To TotalButton
If TopBuS(i) = SubCat Then
TopBuIDT(TotalButtonT) = TopBuID(i)
TopBuST(TotalButtonT) = TopBuS(i)
TopBuCT(TotalButtonT) = TopBuC(i)
TopBuTT(TotalButtonT) = TopBuT(i)
Set TopBuIT(TotalButtonT) = TopBuI(i)
TopBuGT(TotalButtonT) = TopBuG(i)
TotalButtonT = TotalButtonT + 1
End If
Next
Button_left(0).Visible = False
Button_center(0).Visible = False
Button_right(0).Visible = False
Button_Caption(0).Visible = True
Button_Icon(0).Visible = True
ButMouse(0).Visible = True
xt = ButMouse.UBound + 1
For i = xt To (TotalButtonT - 1) + xt
If i <> 0 Then
Load Button_left(i)
Load Button_center(i)
Load Button_right(i)
Load Button_left_over(i)
Load Button_center_over(i)
Load Button_right_over(i)
Load Button_Caption(i)
Load Button_Icon(i)
Load Glip_on(i)
Load Glip_off(i)
Load ButMouse(i)
End If
ButMouse(i).Tag = TopBuIDT(i - xt)
Button_center(i).Tag = CatID
ButMouse(i).Top = Cat_Left_off(0).Top + 60
Button_left(i).Top = ButMouse(i).Top
Button_center(i).Top = ButMouse(i).Top
Button_right(i).Top = ButMouse(i).Top
Button_left_over(i).Top = ButMouse(i).Top
Button_center_over(i).Top = ButMouse(i).Top
Button_right_over(i).Top = ButMouse(i).Top
If i = xt Then
posatu = PosIni
Else
posatu = ButMouse(i - 1).Left + ButMouse(i - 1).Width + 30
End If
ButMouse(i).Left = posatu
Button_left(i).Left = ButMouse(i).Left
Button_left_over(i).Left = Button_left(i).Left
Button_center(i).Left = Button_left(i).Left + Button_left(i).Width
Button_center_over(i).Left = Button_center(i).Left
Button_Caption(i).Caption = TopBuCT(i - xt)
Set Button_Icon(i) = TopBuIT(i - xt)
If m_BC = True Then
ESP = Button_center(i).Height - (Button_Icon(i).Height + Button_Caption(i).Height)
If TopBuGT(i - xt) = True Then
Button_Icon(i).Top = Button_center(i).Top + ((ESP - (Button_Caption(i).Height / 2)) / 2)
Else
Button_Icon(i).Top = Button_center(i).Top + ((ESP) / 2)
End If
Else
Button_Icon(i).Top = Button_center(i).Top + 90
End If
Button_Caption(i).Top = Button_Icon(i).Top + Button_Icon(i).Height
Glip_off(i).Top = Button_Caption(i).Top + Button_Caption(i).Height + ((Button_Caption(i).Height - Glip_off(i).Height) / 2)
Glip_on(i).Top = Glip_off(i).Top
If Button_Caption(i).Width > Button_Icon(i).Width Then
Button_Caption(i).Left = Button_center(i).Left
esp2 = (Button_Caption(i).Width - Button_Icon(i).Width) / 2
Button_Icon(i).Left = Button_Caption(i).Left + esp2
Area = Button_Caption(i).Width
Else
Button_Icon(i).Left = Button_center(i).Left
esp2 = (Button_Icon(i).Width - Button_Caption(i).Width) / 2
Button_Caption(i).Left = Button_Icon(i).Left + esp2
Area = Button_Icon(i).Width
End If
Glip_off(i).Left = Button_Caption(i).Left + ((Button_Caption(i).Width - Glip_on(i).Width) / 2)
Glip_on(i).Left = Glip_off(i).Left
Button_center(i).Width = Area
Button_center_over(i).Width = Button_center(i).Width
Button_right(i).Left = Button_center(i).Left + Button_center(i).Width
Button_right_over(i).Left = Button_right(i).Left
ButMouse(i).Width = (Button_right(i).Width + Button_right(i).Width) + Button_center(i).Width
ButMouse(i).ToolTipText = TopBuTT(i - xt)
Button_Icon(i).Visible = True
Button_Caption(i).Visible = True
ButMouse(i).Visible = True
If TopBuGT(i - xt) = True Then
Glip_off(i).Visible = True
Glip_off(i).ZOrder 0
Glip_on(i).ZOrder 0
End If
TotalSize = TotalSize + ButMouse(i).Width + 30
Next
ButtonsUpdate = TotalSize - 30
End Function
Public Property Get Theme() As Integer
Theme = m_Theme
End Property
Public Property Let Theme(ByVal New_Theme As Integer)
If New_Theme < 0 Or New_Theme > 2 Then New_Theme = 0
m_Theme = New_Theme
PropertyChanged "Theme"
LoadTheme m_Theme
End Property
Public Property Get ButtonCenter() As Variant
ButtonCenter = m_BC
End Property
Public Property Let ButtonCenter(ByVal New_BC As Variant)
m_BC = New_BC
PropertyChanged "ButtonCenter"
End Property
Private Function LoadTheme(iTema)
Select Case iTema
Case 0
ID = "BLACK"
Cat_Caption(0).ForeColor = &HFFFFFF
TAB_NORMAL = vbWhite
TAB_SELECTED = vbBlack
Button_Caption(0).ForeColor = &H80000008
UserControl.BackColor = &H464646
UserControl.ForeColor = &HFFFFFF
Case 1
ID = "BLUE"
Cat_Caption(0).ForeColor = &HB86A3E
TAB_NORMAL = &H8B4215
TAB_SELECTED = &H8B4215
Button_Caption(0).ForeColor = &H8B4215
UserControl.BackColor = &HDAB08E
UserControl.ForeColor = &H8B4215
Case 2
ID = "SILVER"
Cat_Caption(0).ForeColor = &H6A625C
TAB_NORMAL = &H6A625C
TAB_SELECTED = &H6A625C
Button_Caption(0).ForeColor = &H6A625C
UserControl.BackColor = &HDDD4D0
UserControl.ForeColor = &H6A625C
Case Else
ID = "BLACK"
End Select
Set Barra2.Picture = LoadResPicture(101, ID)
Set BarraLeft.Picture = LoadResPicture(102, ID)
Set BarraRight.Picture = LoadResPicture(103, ID)
Set Cat_Dlg(0).Picture = LoadResPicture(118, ID)
Set Cat_Dlg_on(0).Picture = LoadResPicture(119, ID)
Set Cat_Dlg_over(0).Picture = LoadResPicture(120, ID)
Set Cat_Left_off(0).Picture = LoadResPicture(121, ID)
Set Cat_Center_off(0).Picture = LoadResPicture(122, ID)
Set Cat_Right_off(0).Picture = LoadResPicture(123, ID)
Set Cat_Left_on(0).Picture = LoadResPicture(124, ID)
Set Cat_Center_on(0).Picture = LoadResPicture(125, ID)
Set Cat_Right_on(0).Picture = LoadResPicture(126, ID)
Set Tab_left(0).Picture = LoadResPicture(127, ID)
Set Tab_center(0).Picture = LoadResPicture(128, ID)
Set Tab_right(0).Picture = LoadResPicture(129, ID)
Set Tab_left_over(0).Picture = LoadResPicture(130, ID)
Set Tab_center_over(0).Picture = LoadResPicture(131, ID)
Set Tab_right_over(0).Picture = LoadResPicture(132, ID)
Set Glip_off(0).Picture = LoadResPicture(133, ID)
Set Glip_on(0).Picture = LoadResPicture(134, ID)
Set Button_left_over(0).Picture = LoadResPicture(135, ID)
Set Button_center_over(0).Picture = LoadResPicture(136, ID)
Set Button_right_over(0).Picture = LoadResPicture(137, ID)
Set Button_left(0).Picture = LoadResPicture(138, ID)
Set Button_center(0).Picture = LoadResPicture(139, ID)
Set Button_right(0).Picture = LoadResPicture(140, ID)
End Function
Private Property Get TempDir() As String
Dim sRet As String, c As Long
Dim lErr As Long
sRet = String$(MAX_PATH, 0)
c = GetTempPath(MAX_PATH, sRet)
lErr = Err.LastDllError
If c = 0 Then
Err.Raise 10000 Or lErr, App.EXEName & ".cAniCursor", WinAPIError(lErr)
End If
TempDir = Left$(sRet, c)
End Property
Private Property Get TempFileName(Optional ByVal sPrefix As String, Optional ByVal sPathName As String) As String
Dim lErr As Long
Dim iPos As Long
If sPrefix = "" Then sPrefix = ""
If sPathName = "" Then sPathName = TempDir
Dim sRet As String
sRet = String(MAX_PATH, 0)
GetTempFileName sPathName, sPrefix, 0, sRet
lErr = Err.LastDllError
If Not lErr = 0 Then
Err.Raise 10000 Or lErr, App.EXEName & ".cAniCursor", WinAPIError(lErr)
End If
iPos = InStr(sRet, vbNullChar)
If Not iPos = 0 Then
TempFileName = Left$(sRet, iPos - 1)
End If
End Property
Private Function WinAPIError(ByVal lLastDLLError As Long) As String
Dim sBuff As String
Dim lCount As Long
sBuff = String$(256, 0)
lCount = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0)
If lCount Then
WinAPIError = Left$(sBuff, lCount)
End If
End Function
Public Property Get LoadBackground() As IPicture
Dim sFile As String
Dim b() As Byte
Dim iFile As Integer
On Error GoTo ErrorHandler
Select Case m_Theme
Case 0
b = LoadResData(141, "BLACK")
Case 1
b = LoadResData(141, "BLUE")
Case 2
b = LoadResData(141, "SILVER")
End Select
sFile = TempFileName("LRP")
iFile = FreeFile
Open sFile For Binary Access Write Lock Read As #iFile
Put #iFile, , b
Close #iFile
iFile = 0
Set LoadBackground = LoadPicture(sFile)
KillFile sFile
Exit Property
ErrorHandler:
Dim lErr As Long, sErr As String
lErr = Err.Number: sErr = Err.Description
If Not iFile = 0 Then Close #iFile
KillFile sFile
Err.Raise Err.Number, App.EXEName & ".cLoadResPicture", Err.Description
Exit Property
End Property
Private Property Get LoadResPicture(ByVal ID As Variant, ByVal Format As Variant) As IPicture
Dim sFile As String
Dim b() As Byte
Dim iFile As Integer
On Error GoTo ErrorHandler
b = LoadResData(ID, Format)
sFile = TempFileName("LRP")
iFile = FreeFile
Open sFile For Binary Access Write Lock Read As #iFile
Put #iFile, , b
Close #iFile
iFile = 0
Set LoadResPicture = LoadPicture(sFile)
KillFile sFile
Exit Property
ErrorHandler:
Dim lErr As Long, sErr As String
lErr = Err.Number: sErr = Err.Description
If Not iFile = 0 Then Close #iFile
KillFile sFile
Err.Raise Err.Number, App.EXEName & ".cLoadResPicture", Err.Description
Exit Property
End Property
Private Sub KillFile(ByVal sFile As String)
On Error Resume Next
Kill sFile
End Sub
Public Sub Resize()
UserControl_Resize
End Sub
Public Property Let ImageList(ByVal zImageList As ImageList)
Set zImg = zImageList
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = UserControl.BackColor
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = UserControl.ForeColor
End Property
Fafi
- Antonio Linares
- Site Admin
- Posts: 37481
- Joined: Thu Oct 06, 2005 5:47 pm
- Location: Spain
- Contact:
Re: My RibbonBar + ExplorerBar
Fafi,
Many thanks for publically posting it
Many thanks for publically posting it
fafi wrote:Antonio,
Ok.. no problem Sir !
Here is :RegardsCode: Select all
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long Private Const MAX_PATH = 260 Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100 Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000 Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800 Private Const FORMAT_MESSAGE_FROM_STRING = &H400 Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000 Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200 Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long Dim TotalButton As Integer Dim TotalTabs As Integer Dim TotalCats As Integer Dim TabSelected As String Dim TabID(30) As String Dim TabC(30) As String Dim CatsID(30) As String Dim CatsC(30) As String Dim CatsT(30) As String Dim CatsD(30) As Boolean Dim TopBuID(90) As String Dim TopBuS(90) As String Dim TopBuC(90) As String Dim TopBuI(90) As Picture Dim TopBuT(90) As String Dim TopBuG(90) As Boolean Dim MS As Boolean Dim Mx, My As Integer Event TabClick(ByVal ID As String, ByVal Caption As String) Event CatClick(ByVal ID As String, ByVal Caption As String) Event ButtonClick(ByVal ID As String, ByVal Caption As String) Const m_def_Theme = 0 Const m_def_BC = False Dim m_Theme As Variant Dim m_BC As Boolean Dim zImg As ImageList Dim TAB_NORMAL Dim TAB_SELECTED Private Sub TabNone(Optional Index As Integer = -1) If Index <> -1 Then For i = 0 To Index - 1 If Tab_center_over(i).Visible = True Then Tab_center_over(i).Visible = False Tab_left_over(i).Visible = False Tab_right_over(i).Visible = False End If Next If Tab_center(Index).Visible = False Then Tab_center_over(Index).Visible = True Tab_left_over(Index).Visible = True Tab_right_over(Index).Visible = True End If For i = Index + 1 To TabMouse.UBound If Tab_center_over(i).Visible = True Then Tab_center_over(i).Visible = False Tab_left_over(i).Visible = False Tab_right_over(i).Visible = False End If Next Else For i = 0 To TabMouse.UBound If Tab_center_over(i).Visible = True Then Tab_center_over(i).Visible = False Tab_left_over(i).Visible = False Tab_right_over(i).Visible = False End If Next End If End Sub Private Sub CatNone(Optional Index As Integer = -1) If Index <> -1 Then For i = 0 To Index - 1 If Cat_Center_on(i).Visible = True Then Cat_Center_on(i).Visible = False Cat_Left_on(i).Visible = False Cat_Right_on(i).Visible = False If Cat_Dlg(i).Visible = True Then Cat_Dlg_on(i).Visible = False Cat_Dlg_over(i).Visible = False End If End If Next Cat_Center_on(Index).Visible = True Cat_Left_on(Index).Visible = True Cat_Right_on(Index).Visible = True If Cat_Dlg(Index).Visible = True Then Cat_Dlg_on(Index).Visible = True Cat_Dlg_over(Index).Visible = False End If For i = Index + 1 To CatMouse.UBound If Cat_Center_on(i).Visible = True Then Cat_Center_on(i).Visible = False Cat_Left_on(i).Visible = False Cat_Right_on(i).Visible = False If Cat_Dlg(i).Visible = True Then Cat_Dlg_on(i).Visible = False Cat_Dlg_over(i).Visible = False End If End If Next Else For i = 0 To CatMouse.UBound If Cat_Center_on(i).Visible = True Then Cat_Center_on(i).Visible = False Cat_Left_on(i).Visible = False Cat_Right_on(i).Visible = False If Cat_Dlg(i).Visible = True Then Cat_Dlg_on(i).Visible = False Cat_Dlg_over(i).Visible = False End If End If Next End If End Sub Private Sub ButNone(Optional Index As Integer = -1) If Index <> -1 Then For KL = 0 To Index - 1 If Button_center(KL).Visible = True Then Button_left(KL).Visible = False Button_right(KL).Visible = False Button_center(KL).Visible = False If Glip_off(i).Visible = True Then Glip_on(i).Visible = False End If End If Next If Button_left(Index).Visible = False Then Button_left(Index).Visible = True Button_center(Index).Visible = True Button_right(Index).Visible = True If Glip_off(Index).Visible = True Then Glip_on(Index).Visible = True End If End If For KL = Index + 1 To ButMouse.UBound If Button_center(KL).Visible = True Then Button_left(KL).Visible = False Button_right(KL).Visible = False Button_center(KL).Visible = False If Glip_off(i).Visible = True Then Glip_on(i).Visible = False End If End If Next Else For KL = 0 To ButMouse.UBound If Button_center(KL).Visible = True Then Button_left(KL).Visible = False Button_right(KL).Visible = False Button_center(KL).Visible = False If Glip_off(i).Visible = True Then Glip_on(i).Visible = False End If End If Next End If End Sub Private Sub Barra2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) TabNone CatNone ButNone End Sub Private Sub BarraLeft_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) TabNone CatNone ButNone End Sub Private Sub BarraRight_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) TabNone CatNone ButNone End Sub Private Sub ButMouse_Click(Index As Integer) RaiseEvent ButtonClick(ButMouse(Index).Tag, Button_Caption(Index).Caption) End Sub Private Sub ButMouse_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Button_left_over(Index).Visible = True Button_center_over(Index).Visible = True Button_right_over(Index).Visible = True End Sub Private Sub ButMouse_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) TabNone CatNone Button_center(Index).Tag ButNone Index End Sub Private Sub ButMouse_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Button_left_over(Index).Visible = False Button_center_over(Index).Visible = False Button_right_over(Index).Visible = False End Sub Private Sub Cat_Dlg_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) TabNone CatNone Index ButNone End Sub Private Sub Cat_Dlg_on_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) TabNone CatNone Index ButNone Cat_Dlg_over(Index).Visible = True End Sub Private Sub Cat_Dlg_over_Click(Index As Integer) RaiseEvent CatClick(Cat_Caption(Index).Tag, Cat_Caption(Index).Caption) End Sub Private Sub CatMouse_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) TabNone CatNone Index ButNone End Sub Private Sub TabMouse_Click(Index As Integer) TabNone For i = 0 To Index - 1 Tab_center(i).Visible = False Tab_left(i).Visible = False Tab_right(i).Visible = False Tab_caption(i).ForeColor = TAB_NORMAL Next Tab_caption(Index).ForeColor = TAB_SELECTED Tab_center(Index).Visible = True Tab_left(Index).Visible = True Tab_right(Index).Visible = True For i = Index + 1 To TabMouse.UBound Tab_center(i).Visible = False Tab_left(i).Visible = False Tab_right(i).Visible = False Tab_caption(i).ForeColor = TAB_NORMAL Next TabSelected = TabID(Index) CatsUpdate RaiseEvent TabClick(TabID(Index), TabC(Index)) End Sub Private Sub TabMouse_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) TabNone Index CatNone ButNone End Sub Private Sub UserControl_Initialize() Barra2.Top = -(26 * 15) BarraLeft.Top = Barra2.Top BarraRight.Top = Barra2.Top UserControl.Height = Barra2.Height Barra2.Width = 2048 * 15 TotalTopButton = 0 TotalButton = 0 TotalTabs = 0 TotalCats = 0 TabSelected = "" TabMouse(0).BackStyle = 0 CatMouse(0).BackStyle = 0 ButMouse(0).BackStyle = 0 End Sub Private Sub TabsUpdate() On Error Resume Next For i = 1 To (TotalTabs - 1) Unload Tab_caption(i) Unload Tab_left(i) Unload Tab_center(i) Unload Tab_right(i) Unload Tab_left_over(i) Unload Tab_center_over(i) Unload Tab_right_over(i) Unload TabMouse(i) Next For i = 0 To (TotalTabs - 1) If i <> 0 Then Load Tab_caption(i) Load Tab_left(i) Load Tab_center(i) Load Tab_right(i) Load Tab_left_over(i) Load Tab_center_over(i) Load Tab_right_over(i) Load TabMouse(i) Tab_left(i).Left = Tab_right(i - 1).Left + Tab_right(i).Width Else Tab_left(0).Left = 90 End If TabMouse(i).Left = Tab_left(i).Left Tab_caption(i).Top = 0 + 60 Tab_center(i).Top = 0 Tab_left(i).Top = 0 Tab_right(i).Top = 0 Tab_center_over(i).Top = 0 Tab_left_over(i).Top = 0 Tab_right_over(i).Top = 0 TabMouse(i).Top = 0 Tab_caption(i) = TabC(i) Tab_center(i).Width = Tab_caption(i).Width Tab_center(i).Left = Tab_left(i).Left + Tab_left(i).Width Tab_caption(i).Left = Tab_center(i).Left Tab_right(i).Left = Tab_center(i).Left + Tab_center(i).Width Tab_center_over(i).Width = Tab_center(i).Width Tab_center_over(i).Left = Tab_center(i).Left Tab_left_over(i).Left = Tab_left(i).Left Tab_right_over(i).Left = Tab_right(i).Left TabMouse(i).Width = Tab_left(i).Width + Tab_right(i).Width + Tab_center(i).Width Tab_caption(i).ForeColor = TAB_NORMAL Tab_caption(i).Visible = True If i = 0 Then Tab_center(i).Visible = True Tab_left(i).Visible = True Tab_right(i).Visible = True Tab_caption(i).ForeColor = TAB_SELECTED End If TabMouse(i).Visible = True Tab_center(i).ZOrder 0 Tab_left(i).ZOrder 0 Tab_right(i).ZOrder 0 Tab_center_over(i).ZOrder 0 Tab_left_over(i).ZOrder 0 Tab_right_over(i).ZOrder 0 Tab_caption(i).ZOrder 0 TabMouse(i).ZOrder 0 Next End Sub Private Sub CatsUpdate() On Error Resume Next ztopo = 360 Cat_Center_off(0).Top = ztopo Cat_Center_on(0).Top = ztopo Cat_Left_off(0).Top = ztopo Cat_Left_on(0).Top = ztopo Cat_Right_off(0).Top = ztopo Cat_Right_on(0).Top = ztopo CatMouse(0).Top = ztopo Cat_Caption(0).Top = 1400 Dim TotalCatsT As Integer Dim CatsIDT(30) As String Dim CatsCT(30) As String Dim CatsTT(30) As String Dim CatsDT(30) As Boolean TotalCatsT = 0 For i = 0 To TotalCats If CatsT(i) = TabSelected And TabSelected <> "" And CatsT(i) <> "" Then CatsIDT(TotalCatsT) = CatsID(i) CatsTT(TotalCatsT) = CatsT(i) CatsCT(TotalCatsT) = CatsC(i) CatsDT(TotalCatsT) = CatsD(i) TotalCatsT = TotalCatsT + 1 End If Next For i = 1 To CatMouse.UBound Unload Cat_Left_off(i) Unload Cat_Left_on(i) Unload Cat_Right_off(i) Unload Cat_Right_on(i) Unload Cat_Center_off(i) Unload Cat_Center_on(i) Unload Cat_Caption(i) Unload CatMouse(i) Unload Cat_Dlg(i) Unload Cat_Dlg_on(i) Unload Cat_Dlg_over(i) Next For i = 1 To Button_center.UBound Unload Button_left(i) Unload Button_center(i) Unload Button_right(i) Unload Button_left_over(i) Unload Button_center_over(i) Unload Button_right_over(i) Unload Button_Caption(i) Unload Button_Icon(i) Unload Glip_on(i) Unload Glip_off(i) Unload ButMouse(i) Next Button_left(0).Visible = False Button_center(0).Visible = False Button_right(0).Visible = False Button_Caption(0).Visible = False Button_Icon(0).Visible = False ButMouse(0).Visible = False Cat_Left_off(0).Visible = False Cat_Left_on(0).Visible = False Cat_Right_off(0).Visible = False Cat_Right_on(0).Visible = False Cat_Center_off(0).Visible = False Cat_Center_on(0).Visible = False Cat_Caption(0).Visible = False CatMouse(0).Visible = False Cat_Dlg(0).Visible = False Cat_Dlg_on(0).Visible = False Cat_Dlg_over(0).Visible = False For i = 0 To (TotalCatsT - 1) If i <> 0 Then Load Cat_Left_off(i) Load Cat_Left_on(i) Load Cat_Right_off(i) Load Cat_Right_on(i) Load Cat_Center_off(i) Load Cat_Center_on(i) Load Cat_Caption(i) Load CatMouse(i) Load Cat_Dlg(i) Load Cat_Dlg_on(i) Load Cat_Dlg_over(i) Cat_Left_off(i).Left = Cat_Right_off(i - 1).Left + Cat_Right_off(i).Width Else Cat_Left_off(i).Left = 120 End If CatMouse(i).Left = Cat_Left_off(i).Left Cat_Caption(i).Caption = CatsCT(i) Cat_Caption(i).Tag = CatsIDT(i) Cat_Center_off(i).Left = Cat_Left_off(i).Left + Cat_Left_off(i).Width BUTSIZE = ButtonsUpdate(CatsIDT(i), Cat_Center_off(i).Left, i + 0) If CatsDT(i) = True Then Cat_Center_off(i).Width = Cat_Caption(i).Width + Cat_Dlg(i).Width Else Cat_Center_off(i).Width = Cat_Caption(i).Width End If If Cat_Center_off(i).Width < BUTSIZE Then Cat_Center_off(i).Width = BUTSIZE Cat_Caption(i).Left = Cat_Center_off(i).Left + ((Cat_Center_off(i).Width - Cat_Caption(i).Width) / 2) Else Cat_Caption(i).Left = Cat_Center_off(i).Left End If Cat_Right_off(i).Left = Cat_Center_off(i).Left + Cat_Center_off(i).Width Cat_Center_on(i).Width = Cat_Center_off(i).Width Cat_Center_on(i).Left = Cat_Center_off(i).Left Cat_Left_on(i).Left = Cat_Left_off(i).Left Cat_Right_on(i).Left = Cat_Right_off(i).Left CatMouse(i).Width = Cat_Left_off(i).Width + Cat_Right_off(i).Width + Cat_Center_off(i).Width Cat_Caption(i).Visible = True Cat_Center_off(i).Visible = True Cat_Left_off(i).Visible = True Cat_Right_off(i).Visible = True CatMouse(i).Visible = True Cat_Center_off(i).ZOrder 0 Cat_Left_off(i).ZOrder 0 Cat_Right_off(i).ZOrder 0 Cat_Center_on(i).ZOrder 0 Cat_Left_on(i).ZOrder 0 Cat_Right_on(i).ZOrder 0 Cat_Caption(i).ZOrder 0 CatMouse(i).ZOrder 0 Cat_Dlg(i).Left = (Cat_Right_off(i).Left - Cat_Dlg(i).Width) + 15 Cat_Dlg(i).Top = (Cat_Right_off(i).Top + Cat_Right_off(i).Height) - (Cat_Dlg(i).Height + 60) Cat_Dlg_on(i).Left = Cat_Dlg(i).Left Cat_Dlg_over(i).Left = Cat_Dlg(i).Left Cat_Dlg_on(i).Top = Cat_Dlg(i).Top Cat_Dlg_over(i).Top = Cat_Dlg(i).Top Cat_Dlg_on(i).Visible = False Cat_Dlg_over(i).Visible = False If CatsDT(i) = True Then Cat_Dlg(i).Visible = True End If Cat_Dlg(i).ZOrder 0 Cat_Dlg_on(i).ZOrder 0 Cat_Dlg_over(i).ZOrder 0 Next DoEvents For KL = 0 To ButMouse.UBound Button_left(KL).Visible = False Button_left(KL).ZOrder 0 Button_right(KL).Visible = False Button_right(KL).ZOrder 0 Button_center(KL).Visible = False Button_center(KL).ZOrder 0 Button_left_over(KL).Visible = False Button_left_over(KL).ZOrder 0 Button_right_over(KL).Visible = False Button_right_over(KL).ZOrder 0 Button_center_over(KL).Visible = False Button_center_over(KL).ZOrder 0 Button_Icon(KL).ZOrder 0 Button_Caption(KL).ZOrder 0 Glip_off(KL).ZOrder 0 Glip_on(KL).ZOrder 0 ButMouse(KL).ZOrder 0 Next End Sub Private Sub UserControl_Resize() 'On Error Resume Next UserControl.Height = Barra2.Height - (26 * 15) 'UserControl.Width = UserControl.ParentControls.Item(0).ScaleWidth 'BarraRight.Left = UserControl.Width - BarraRight.Width End Sub Public Sub Refresh() UserControl_Resize TabsUpdate CatsUpdate End Sub Private Sub UserControl_InitProperties() m_Theme = m_def_Theme m_BC = m_def_BC End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag) m_Theme = PropBag.ReadProperty("Theme", m_def_Theme) m_BC = PropBag.ReadProperty("ButtonCenter", m_def_BC) End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("Theme", m_Theme, m_def_Theme) Call PropBag.WriteProperty("ButtonCenter", m_BC, m_def_BC) Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H464646) Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &HFFFFFF) End Sub Public Function AddTab(zID As String, zCaption As String) As Boolean TotalTabs = TotalTabs + 1 TabID(TotalTabs - 1) = zID zCaption = Replace(zCaption, vbNewLine, " ") TabC(TotalTabs - 1) = zCaption If TabSelected = "" Then TabSelected = zID End If End Function Public Function AddCat(zID As String, zTab As String, zCaption As String, zDlgButton As Boolean) As Boolean TotalCats = TotalCats + 1 CatsID(TotalCats - 1) = zID CatsT(TotalCats - 1) = zTab zCaption = Replace(zCaption, vbNewLine, " ") CatsC(TotalCats - 1) = zCaption CatsD(TotalCats - 1) = zDlgButton End Function Public Function AddButton(zID As String, zSubCat As String, zCaption As String, zPicture As Integer, Optional zMore As Boolean = False, Optional zToolTip As String) As Boolean TotalButton = TotalButton + 1 TopBuID(TotalButton - 1) = zID TopBuS(TotalButton - 1) = zSubCat TopBuC(TotalButton - 1) = zCaption If zToolTip = "" Or zToolTip = Null Then If InStr(zCaption, vbNewLine) Then zCaption = Replace(zCaption, vbNewLine, " ") End If TopBuT(TotalButton - 1) = zCaption Else zToolTip = Replace(zToolTip, vbNewLine, " ") TopBuT(TotalButton - 1) = zToolTip End If Set TopBuI(TotalButton - 1) = zImg.ListImages.Item(zPicture).Picture TopBuG(TotalButton - 1) = zMore End Function Private Function ButtonsUpdate(SubCat As String, PosIni As Integer, CatID As Integer) As Integer On Error Resume Next Dim TotalButtonT As Integer Dim TopBuIDT(90) As String Dim TopBuST(90) As String Dim TopBuCT(90) As String Dim TopBuIT(90) As Picture Dim TopBuTT(90) As String Dim TopBuGT(90) As Boolean TotalSize = 0 TotalButtonT = 0 For i = 0 To TotalButton If TopBuS(i) = SubCat Then TopBuIDT(TotalButtonT) = TopBuID(i) TopBuST(TotalButtonT) = TopBuS(i) TopBuCT(TotalButtonT) = TopBuC(i) TopBuTT(TotalButtonT) = TopBuT(i) Set TopBuIT(TotalButtonT) = TopBuI(i) TopBuGT(TotalButtonT) = TopBuG(i) TotalButtonT = TotalButtonT + 1 End If Next Button_left(0).Visible = False Button_center(0).Visible = False Button_right(0).Visible = False Button_Caption(0).Visible = True Button_Icon(0).Visible = True ButMouse(0).Visible = True xt = ButMouse.UBound + 1 For i = xt To (TotalButtonT - 1) + xt If i <> 0 Then Load Button_left(i) Load Button_center(i) Load Button_right(i) Load Button_left_over(i) Load Button_center_over(i) Load Button_right_over(i) Load Button_Caption(i) Load Button_Icon(i) Load Glip_on(i) Load Glip_off(i) Load ButMouse(i) End If ButMouse(i).Tag = TopBuIDT(i - xt) Button_center(i).Tag = CatID ButMouse(i).Top = Cat_Left_off(0).Top + 60 Button_left(i).Top = ButMouse(i).Top Button_center(i).Top = ButMouse(i).Top Button_right(i).Top = ButMouse(i).Top Button_left_over(i).Top = ButMouse(i).Top Button_center_over(i).Top = ButMouse(i).Top Button_right_over(i).Top = ButMouse(i).Top If i = xt Then posatu = PosIni Else posatu = ButMouse(i - 1).Left + ButMouse(i - 1).Width + 30 End If ButMouse(i).Left = posatu Button_left(i).Left = ButMouse(i).Left Button_left_over(i).Left = Button_left(i).Left Button_center(i).Left = Button_left(i).Left + Button_left(i).Width Button_center_over(i).Left = Button_center(i).Left Button_Caption(i).Caption = TopBuCT(i - xt) Set Button_Icon(i) = TopBuIT(i - xt) If m_BC = True Then ESP = Button_center(i).Height - (Button_Icon(i).Height + Button_Caption(i).Height) If TopBuGT(i - xt) = True Then Button_Icon(i).Top = Button_center(i).Top + ((ESP - (Button_Caption(i).Height / 2)) / 2) Else Button_Icon(i).Top = Button_center(i).Top + ((ESP) / 2) End If Else Button_Icon(i).Top = Button_center(i).Top + 90 End If Button_Caption(i).Top = Button_Icon(i).Top + Button_Icon(i).Height Glip_off(i).Top = Button_Caption(i).Top + Button_Caption(i).Height + ((Button_Caption(i).Height - Glip_off(i).Height) / 2) Glip_on(i).Top = Glip_off(i).Top If Button_Caption(i).Width > Button_Icon(i).Width Then Button_Caption(i).Left = Button_center(i).Left esp2 = (Button_Caption(i).Width - Button_Icon(i).Width) / 2 Button_Icon(i).Left = Button_Caption(i).Left + esp2 Area = Button_Caption(i).Width Else Button_Icon(i).Left = Button_center(i).Left esp2 = (Button_Icon(i).Width - Button_Caption(i).Width) / 2 Button_Caption(i).Left = Button_Icon(i).Left + esp2 Area = Button_Icon(i).Width End If Glip_off(i).Left = Button_Caption(i).Left + ((Button_Caption(i).Width - Glip_on(i).Width) / 2) Glip_on(i).Left = Glip_off(i).Left Button_center(i).Width = Area Button_center_over(i).Width = Button_center(i).Width Button_right(i).Left = Button_center(i).Left + Button_center(i).Width Button_right_over(i).Left = Button_right(i).Left ButMouse(i).Width = (Button_right(i).Width + Button_right(i).Width) + Button_center(i).Width ButMouse(i).ToolTipText = TopBuTT(i - xt) Button_Icon(i).Visible = True Button_Caption(i).Visible = True ButMouse(i).Visible = True If TopBuGT(i - xt) = True Then Glip_off(i).Visible = True Glip_off(i).ZOrder 0 Glip_on(i).ZOrder 0 End If TotalSize = TotalSize + ButMouse(i).Width + 30 Next ButtonsUpdate = TotalSize - 30 End Function Public Property Get Theme() As Integer Theme = m_Theme End Property Public Property Let Theme(ByVal New_Theme As Integer) If New_Theme < 0 Or New_Theme > 2 Then New_Theme = 0 m_Theme = New_Theme PropertyChanged "Theme" LoadTheme m_Theme End Property Public Property Get ButtonCenter() As Variant ButtonCenter = m_BC End Property Public Property Let ButtonCenter(ByVal New_BC As Variant) m_BC = New_BC PropertyChanged "ButtonCenter" End Property Private Function LoadTheme(iTema) Select Case iTema Case 0 ID = "BLACK" Cat_Caption(0).ForeColor = &HFFFFFF TAB_NORMAL = vbWhite TAB_SELECTED = vbBlack Button_Caption(0).ForeColor = &H80000008 UserControl.BackColor = &H464646 UserControl.ForeColor = &HFFFFFF Case 1 ID = "BLUE" Cat_Caption(0).ForeColor = &HB86A3E TAB_NORMAL = &H8B4215 TAB_SELECTED = &H8B4215 Button_Caption(0).ForeColor = &H8B4215 UserControl.BackColor = &HDAB08E UserControl.ForeColor = &H8B4215 Case 2 ID = "SILVER" Cat_Caption(0).ForeColor = &H6A625C TAB_NORMAL = &H6A625C TAB_SELECTED = &H6A625C Button_Caption(0).ForeColor = &H6A625C UserControl.BackColor = &HDDD4D0 UserControl.ForeColor = &H6A625C Case Else ID = "BLACK" End Select Set Barra2.Picture = LoadResPicture(101, ID) Set BarraLeft.Picture = LoadResPicture(102, ID) Set BarraRight.Picture = LoadResPicture(103, ID) Set Cat_Dlg(0).Picture = LoadResPicture(118, ID) Set Cat_Dlg_on(0).Picture = LoadResPicture(119, ID) Set Cat_Dlg_over(0).Picture = LoadResPicture(120, ID) Set Cat_Left_off(0).Picture = LoadResPicture(121, ID) Set Cat_Center_off(0).Picture = LoadResPicture(122, ID) Set Cat_Right_off(0).Picture = LoadResPicture(123, ID) Set Cat_Left_on(0).Picture = LoadResPicture(124, ID) Set Cat_Center_on(0).Picture = LoadResPicture(125, ID) Set Cat_Right_on(0).Picture = LoadResPicture(126, ID) Set Tab_left(0).Picture = LoadResPicture(127, ID) Set Tab_center(0).Picture = LoadResPicture(128, ID) Set Tab_right(0).Picture = LoadResPicture(129, ID) Set Tab_left_over(0).Picture = LoadResPicture(130, ID) Set Tab_center_over(0).Picture = LoadResPicture(131, ID) Set Tab_right_over(0).Picture = LoadResPicture(132, ID) Set Glip_off(0).Picture = LoadResPicture(133, ID) Set Glip_on(0).Picture = LoadResPicture(134, ID) Set Button_left_over(0).Picture = LoadResPicture(135, ID) Set Button_center_over(0).Picture = LoadResPicture(136, ID) Set Button_right_over(0).Picture = LoadResPicture(137, ID) Set Button_left(0).Picture = LoadResPicture(138, ID) Set Button_center(0).Picture = LoadResPicture(139, ID) Set Button_right(0).Picture = LoadResPicture(140, ID) End Function Private Property Get TempDir() As String Dim sRet As String, c As Long Dim lErr As Long sRet = String$(MAX_PATH, 0) c = GetTempPath(MAX_PATH, sRet) lErr = Err.LastDllError If c = 0 Then Err.Raise 10000 Or lErr, App.EXEName & ".cAniCursor", WinAPIError(lErr) End If TempDir = Left$(sRet, c) End Property Private Property Get TempFileName(Optional ByVal sPrefix As String, Optional ByVal sPathName As String) As String Dim lErr As Long Dim iPos As Long If sPrefix = "" Then sPrefix = "" If sPathName = "" Then sPathName = TempDir Dim sRet As String sRet = String(MAX_PATH, 0) GetTempFileName sPathName, sPrefix, 0, sRet lErr = Err.LastDllError If Not lErr = 0 Then Err.Raise 10000 Or lErr, App.EXEName & ".cAniCursor", WinAPIError(lErr) End If iPos = InStr(sRet, vbNullChar) If Not iPos = 0 Then TempFileName = Left$(sRet, iPos - 1) End If End Property Private Function WinAPIError(ByVal lLastDLLError As Long) As String Dim sBuff As String Dim lCount As Long sBuff = String$(256, 0) lCount = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0) If lCount Then WinAPIError = Left$(sBuff, lCount) End If End Function Public Property Get LoadBackground() As IPicture Dim sFile As String Dim b() As Byte Dim iFile As Integer On Error GoTo ErrorHandler Select Case m_Theme Case 0 b = LoadResData(141, "BLACK") Case 1 b = LoadResData(141, "BLUE") Case 2 b = LoadResData(141, "SILVER") End Select sFile = TempFileName("LRP") iFile = FreeFile Open sFile For Binary Access Write Lock Read As #iFile Put #iFile, , b Close #iFile iFile = 0 Set LoadBackground = LoadPicture(sFile) KillFile sFile Exit Property ErrorHandler: Dim lErr As Long, sErr As String lErr = Err.Number: sErr = Err.Description If Not iFile = 0 Then Close #iFile KillFile sFile Err.Raise Err.Number, App.EXEName & ".cLoadResPicture", Err.Description Exit Property End Property Private Property Get LoadResPicture(ByVal ID As Variant, ByVal Format As Variant) As IPicture Dim sFile As String Dim b() As Byte Dim iFile As Integer On Error GoTo ErrorHandler b = LoadResData(ID, Format) sFile = TempFileName("LRP") iFile = FreeFile Open sFile For Binary Access Write Lock Read As #iFile Put #iFile, , b Close #iFile iFile = 0 Set LoadResPicture = LoadPicture(sFile) KillFile sFile Exit Property ErrorHandler: Dim lErr As Long, sErr As String lErr = Err.Number: sErr = Err.Description If Not iFile = 0 Then Close #iFile KillFile sFile Err.Raise Err.Number, App.EXEName & ".cLoadResPicture", Err.Description Exit Property End Property Private Sub KillFile(ByVal sFile As String) On Error Resume Next Kill sFile End Sub Public Sub Resize() UserControl_Resize End Sub Public Property Let ImageList(ByVal zImageList As ImageList) Set zImg = zImageList End Property Public Property Get BackColor() As OLE_COLOR BackColor = UserControl.BackColor End Property Public Property Get ForeColor() As OLE_COLOR ForeColor = UserControl.ForeColor End Property
Fafi
Re: My RibbonBar + ExplorerBar
Look at here Sir !
>> Dim zImg As ImageList
I can't use this Imagelist :
because come from another OCX ( Microsoft Window Common Control )
and here :
>> Public Property Let ImageList(ByVal zImageList As ImageList)
>> Set zImg = zImageList
>> End Property
oAct:do("Imagelist", oImagelist )
Antonio,
What is Type of oImagelist in FWH ?
if oImageList is Object then I want to change Dim zImg As ImageList with Dim zImg As Object
but still error....
Please Help !
Regards
Fafi
>> Dim zImg As ImageList
I can't use this Imagelist :
because come from another OCX ( Microsoft Window Common Control )
and here :
>> Public Property Let ImageList(ByVal zImageList As ImageList)
>> Set zImg = zImageList
>> End Property
oAct:do("Imagelist", oImagelist )
Antonio,
What is Type of oImagelist in FWH ?
if oImageList is Object then I want to change Dim zImg As ImageList with Dim zImg As Object
but still error....
Please Help !
Regards
Fafi