Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing clsToolbarButton.cls (5.19 KB)
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsToolbarButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
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 Const WM_USER = &H400
Private Const TB_HIDEBUTTON = (WM_USER + 4)
Private Const TB_ISBUTTONHIDDEN = (WM_USER + 12)
Private Const TB_GETBUTTON = (WM_USER + 23)
Private Const TB_BUTTONCOUNT = (WM_USER + 24)
Private Const TB_BUTTONSTRUCTSIZE = (WM_USER + 30)
Private Const TB_MOVEBUTTON = (WM_USER + 82)
Private Type TBBUTTON
iBitmap As Long
idCommand As Long
fsState As Byte
fsStyle As Byte
bReserved1 As Byte
bReserved2 As Byte
dwData As Long
iString As Long
End Type
Private m_hWnd As Long
Private intIndex As Long
Private Function GetButton() As TBBUTTON
Dim btn As TBBUTTON
' send the size of the structure to the toolbar (legacy support)
SendMessage m_hWnd, TB_BUTTONSTRUCTSIZE, Len(btn), ByVal 0
Dim tid As Long
Dim pid As Long
' get process id of the toolbar
tid = GetWindowThreadProcessId(m_hWnd, pid)
Dim hProcess As Long
Dim sharedMem As Long
Dim lWritten As Long
' allocate memory within the toolbar process
sharedMem = GetMemShared(pid, LenB(btn), hProcess)
' get the button
SendMessage m_hWnd, TB_GETBUTTON, intIndex, ByVal sharedMem
' read the memory into the button structure
ReadProcessMemory hProcess, ByVal sharedMem, btn, LenB(btn), lWritten
' cleanup
FreeMemShared hProcess, sharedMem, LenB(btn)
GetButton = btn
End Function
Public Sub Init(ByVal hWnd As Long, ByVal btnIndex As Long)
m_hWnd = hWnd
intIndex = btnIndex
End Sub
Public Property Get Text() As String
Dim btn As TBBUTTON
' send the size of the structure to the toolbar (legacy support)
SendMessage m_hWnd, TB_BUTTONSTRUCTSIZE, Len(btn), ByVal 0
Dim tid As Long
Dim pid As Long
' get process id of the toolbar
tid = GetWindowThreadProcessId(m_hWnd, pid)
Dim hProcess As Long
Dim sharedMem As Long
Dim lWritten As Long
' allocate memory within the toolbar process
sharedMem = GetMemShared(pid, LenB(btn), hProcess)
' get the button
SendMessage m_hWnd, TB_GETBUTTON, intIndex, ByVal sharedMem
' read the memory into the button structure
ReadProcessMemory hProcess, ByVal sharedMem, btn, LenB(btn), lWritten
Dim ptr As Long
Dim TChar As Integer
Dim sBuff As String
ptr = btn.iString
Do
' read the memory into the button structure
ReadProcessMemory hProcess, ByVal ptr, TChar, 2, lWritten
sBuff = sBuff + ChrW(TChar)
ptr = ptr + 2
Loop While TChar
' cleanup
FreeMemShared hProcess, sharedMem, LenB(btn)
Text = Left(sBuff, Len(sBuff) - 1)
End Property
Public Property Get Count() As Long
Count = SendMessage(m_hWnd, TB_BUTTONCOUNT, 0, ByVal 0)
End Property
Public Property Get Visible() As Boolean
Dim btn As TBBUTTON
btn = GetButton()
Visible = Not CBool(SendMessage(m_hWnd, TB_ISBUTTONHIDDEN, btn.idCommand, ByVal 0))
End Property
Public Property Let Visible(ByVal value As Boolean)
Dim btn As TBBUTTON
btn = GetButton()
SendMessage m_hWnd, TB_HIDEBUTTON, btn.idCommand, ByVal CLng(Abs(Not value))
End Property
Public Sub MoveLeft()
If intIndex > 0 Then _
SendMessage m_hWnd, TB_MOVEBUTTON, intIndex, ByVal (intIndex - 1)
End Sub
Public Sub MoveRight()
If intIndex < Me.Count - 1 Then _
SendMessage m_hWnd, TB_MOVEBUTTON, intIndex, ByVal (intIndex + 1)
End Sub
Public Function GetNextButton() As clsToolbarButton
Dim objBtn As clsToolbarButton
If intIndex < Me.Count - 1 Then
Set objBtn = New clsToolbarButton
objBtn.Init m_hWnd, intIndex + 1
Else
Set objBtn = Nothing
End If
End Function
Public Function GetPreviousButton() As clsToolbarButton
Dim objBtn As clsToolbarButton
If intIndex > 0 Then
Set objBtn = New clsToolbarButton
objBtn.Init m_hWnd, intIndex - 1
Else
Set objBtn = Nothing
End If
End Function