*************************************MenuBuilder Class Object Code ******************************************
Option Declare
Use "OpenLogFunctions"

Private Const MF_ENABLED = &H0&
Private Const MF_POPUP = &H10&
Private Const MF_STRING = &H0&
Private Const TPM_LEFTALIGN = &H0

Public Type RectangleTYPE
left As Long
top As Long
right As Long
bottom As Long
End Type

Public Type PointApiTYPE
x As Long
y As Long
End Type

Public Type MsgTYPE
hWnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As PointApiTYPE
End Type

'// PUBLIC API declarations
Declare Public Function W32CreatePopupMenu Lib "user32" Alias "CreatePopupMenu" (_
) As Long

Declare Public Function W32DestroyMenu Lib "user32" Alias "DestroyMenu" (_
Byval hMenu As Long _
) As Long

'// PRIVATE API declarations
Declare Private Function W32GetCursorPos Lib "user32" Alias "GetCursorPos" (_
lpPoint As PointApiTYPE _
) As Long

Declare Private Function W32AppendMenu Lib "user32" Alias "AppendMenuA" (_
Byval hMenu As Long, _
Byval wFlags As Long, _
Byval wIDNewItem As Long, _
Byval lpNewItem As Any _
) As Long

Declare Private Function W32TrackPopupMenu Lib "user32" Alias "TrackPopupMenu" (_
Byval hMenu As Long, _
Byval wFlags As Long, _
Byval x As Long, _
Byval y As Long, _
Byval nReserved As Long, _
Byval hWnd As Long, _
lprc As RectangleTYPE _
) As Long

Declare Private Function W32GetMessage Lib "user32" Alias "GetMessageA" (_
lpMsg As MsgTYPE, _
Byval hWnd As Long, _
Byval wMsgFilterMin As Long, _
Byval wMsgFilterMax As Long _
) As Long

Declare Private Function W32GetActiveWindow Lib "user32" Alias "GetActiveWindow" (_
) As Long

'// The "Entry" class represents one menu item in the cascaded menu. The data can be
'// retrieved from anywhere in anyway. The cascaded menu itself consists of a collection
'// of these objects. Each object has to know its level in the menu, whether or not it
'// is a menu itself, and what to display when the menu is rendered.
Public Class Entry
Private strLabel As String
Private intLevel As Integer
Private blnIsMenu As Boolean

Sub New(pintLevel As Integer, pstrLabel As String, pblnIsMenu As Boolean)
Me.intLevel% = pintLevel%
Me.strLabel$ = pstrLabel$
Me.blnIsMenu = pblnIsMenu
End Sub

Public Property Get Level As Integer
Level% = Me.intLevel%
End Property

Public Property Get Label As String
Label$ = Me.strLabel$
End Property

Public Property Get IsMenu As Boolean
IsMenu = Me.blnIsMenu
End Property
End Class

Public Class MenuBuilder
Private m_baseMenuHandle As Long
Private m_menuHandleArray() As Long
Private m_menuList List As String
Private m_cursor As pointApiType
Private m_rectangleData As rectangleType
Private m_msgData As msgType
Private m_index As Long
Private m_currentLevel As Integer

Sub New(pEntryArray() As Entry)
On Error Goto errorHandler
Dim tmpEntryValue As Entry
Dim arraySize As Integer
Dim counter As Integer
Dim currentLevel As Integer
Dim lngID As Long
Dim returnVal As Long

If Not isWin32 Then End

arraySize = Ubound(pEntryArray)
If arraySize <= 0 Then End

Redim m_menuHandleArray(0) As Long
m_baseMenuHandle = W32CreatePopupMenu()
m_menuHandleArray(0) = m_baseMenuHandle
counter = 1
Forall ntry In pEntryArray
currentLevel% = ntry.Level%
If ntry.isMenu Then
Redim Preserve m_menuHandleArray(currentLevel% + 1) As Long
m_menuHandleArray(currentLevel% + 1) = addMenu(m_menuHandleArray(currentLevel%), ntry.Label$)
Else
returnVal = addItem(m_menuHandleArray(currentLevel%),lngID, ntry.Label$)
m_menuList(returnVal) = ntry.Label$
End If
End Forall

exitThis:
Exit Sub

errorHandler:
Messagebox LogError
End
End Sub

Private Function isWin32() As Boolean
Dim session As New NotesSession
isWin32 = True

If Not(Strcompare(session.Platform, "Windows/32",5) = 0 ) Then isWin32 = False

End Function

Private Function addMenu(plngParentMenu As Long, pstrLabel As String) As Long
On Error Goto errorHandler

Dim lngNewMenu As Long

lngNewMenu& = W32CreatePopupMenu()
Call W32AppendMenu(plngParentMenu&, MF_ENABLED Or MF_POPUP, lngNewMenu&, Byval pstrLabel$)
addMenu& = lngNewMenu&

exitThis:
Exit Function
errorHandler:
Messagebox LogError
End
End Function

Private Function addItem(plngMenu As Long, plngID As Long, pstrText As String) As Long
On Error Goto errorHandler

plngID& = plngID& + 1
Call W32AppendMenu(plngMenu&, MF_ENABLED Or MF_STRING, plngID&, Byval pstrText$)
addItem& = plngID&
Exit Function

exitThis:
Exit Function
errorHandler:
Messagebox LogError
End
End Function

Public Function getChoice() As String
Dim returnVal As Long

returnVal = trackMenu()
If returnVal <> 0 Then
getChoice = m_menuList(returnVal)
Else
getChoice = ""
End If
End Function

Private Function trackMenu() As Long
On Error Goto errorHandler

Dim lngRetCode As Long

Call W32GetCursorPos(m_cursor)

lngRetCode& = W32TrackPopupMenu(m_baseMenuHandle, TPM_LEFTALIGN, m_cursor.x, m_cursor.y, 0, W32GetActiveWindow(), m_rectangleData)
lngRetCode& = W32GetMessage(m_msgData, W32GetActiveWindow(), 0, 0)

lngRetCode& = Abs(m_msgData.wParam)
If m_msgData.message = 273 Then
trackMenu& = lngRetCode&
End If
exitThis:
Exit Function

errorHandler:
Messagebox LogError
End
End Function

Sub Delete
If m_baseMenuHandle <> 0 Then
Call W32DestroyMenu(m_baseMenuHandle)
End If
End Sub
End Class