VERSION 5.00
Begin VB.UserControl ctMenuA 
   BackColor       =   &H80000005&
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   1170
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1200
   ClipBehavior    =   0  'None
   ClipControls    =   0   'False
   EditAtDesignTime=   -1  'True
   FillStyle       =   0  'Solid
   HasDC           =   0   'False
   HitBehavior     =   0  'None
   KeyPreview      =   -1  'True
   PaletteMode     =   4  'None
   ScaleHeight     =   78
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   80
   Begin VB.CommandButton eButton 
      Caption         =   "..."
      Height          =   255
      Index           =   1
      Left            =   840
      TabIndex        =   2
      TabStop         =   0   'False
      Top             =   840
      Visible         =   0   'False
      Width           =   255
   End
   Begin VB.CommandButton eButton 
      Caption         =   "..."
      Height          =   255
      Index           =   0
      Left            =   840
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   120
      Visible         =   0   'False
      Width           =   255
   End
   Begin VB.Image ePic 
      Height          =   480
      Index           =   0
      Left            =   360
      Top             =   120
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Label eLabel 
      Alignment       =   2  'Center
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      Height          =   195
      Index           =   0
      Left            =   90
      TabIndex        =   0
      Top             =   600
      Visible         =   0   'False
      Width           =   1005
      WordWrap        =   -1  'True
   End
End
Attribute VB_Name = "ctMenuA"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ctMenuA, Scroll Version
' custom usercontrol for Visual Basic 6
' Copyright (C) 2003,2004 Jan Vorel
' This program is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2 of the License, or
' (at your option) any later version.

' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.

' You should have received a copy of the GNU General Public License
' along with this program; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

' This is a shared modul, class modul, usercontrol or form. It is also
' published under the GNU General Public License.

' If you have any questions, suggestions or bug reports about this product,
' contact me: info@ctuser.net; Do not contact me about general B.A.S.I.C.
' language or A.P.I. issues

' ctMenuA_Flag_Keys
' ctMenuA_Flag_GetKeys
' ctMenuA_Flag_GetCurKey
' ctMenuA_Flag_UpdateItemCount
' ctMenuA_Flag_GetItemCount
' ctMenuA_Flag_UseLoadIconFromFile
' ctMenuA_Flag_AddRemoveItemA
'   ctMenuA_Flag_AddItemA
'   ctMenuA_Flag_RemoveItemA
' ctMenuA_Flag_SetCurItem
' ctMenuA_Flag_GetCurItem
' ctMenuA_Flag_SetTextHeight
' ctMenuA_Flag_SetIconHeight
' ctMenuA_Flag_FlatButtons
' ctMenuA_Flag_FlatButtonsEx (Flats without declarations)
' ctMenuA_Flag_NoResize
' ctMenuA_Flag_AutoAlignCenter
' ctMenuA_Flag_AutoAlignStretch
' ctMenuA_Flag_KeyAndMouseEvents
' ctMenuA_Flag_KeyAndMouseEventsEx

'ctMenuA_Flag_AddRemoveItemExQT

Option Explicit
Option Base 0

Dim xSpaceGen As Long
Dim xSpaceIHeight As Long
Dim xSpaceTHeight As Long
Dim xCount As Long
Dim xCurrent As Long
Dim xHasFocus As Boolean

Private Const xSpaceTLeft As Long = 6&
Private Const xSpaceTWidth As Long = 12&

#If ctMenuA_Flag_Keys Then
  Public Event ItemClick(ByVal Index As Long, ByVal Key As String)
  #Else
  Public Event ItemClick(ByVal Index As Long)
  #End If

#If ctMenuA_Flag_FlatButtons Then
  Private Declare Function GetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  #End If

#If ctMenuA_Flag_FlatButtons Or ctMenuA_Flag_FlatButtonsEx Then
  Private xFlButtons As Boolean
  #End If


#If ctMenuA_Flag_Keys Then
  Private Const xMaxCount As Long = 256&
  Private Const xMaxCountX As Long = 255&
  Dim xKey(xMaxCountX) As String
  #End If
















Dim xPage As Long
Dim xPages As Long
'Private xFlButtons As Boolean

Private Const xSpaceBTop As Long = 3 'Integer = 0
Private Const xSpaceBRight As Long = 3 ' Integer = 3
Private Const xSpaceBBottom As Long = 3 'Integer = 3
'Private Const xSpaceTLeft As Long = 6 ' Integer = 6
'Private Const xSpaceTWidth As Long = 12 ' Integer = 12

'Public Event ItemClick(ByVal Index As Long)

Public Property Let ItemCount(ByVal Count As Long)
  #If ctMenuA_Flag_UpdateItemCount Then
    Dim xLong1 As Long
    Dim xLong2 As Long
    Dim xLong3 As Long
    
    If Count = xCount Then Exit Property
    xLong2 = Count
    
    If Count < xCount Then
      If Count = 0 Then
        ePic(0).Visible = False
        eLabel(0).Visible = False
        Count = 1
        End If
      For xLong1 = xCount - 1 To Count Step -1
        Unload ePic(xLong1)
        Unload eLabel(xLong1)
        Next
      Else
      If xCount = 0 Then
        xLong3 = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (-xPage) + xSpaceGen
        'ePic(xLong1).Top = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (-xPage) + xSpaceGen
        'eLabel(xLong1).Top = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (-xPage) + xSpaceGen + xSpaceIHeight
        With ePic(0)
          .Top = xLong3
          .Visible = True
          End With
        With eLabel(0)
          .Top = xLong3 + xSpaceIHeight
          .Visible = True
          End With
        xCurrent = 0
        xCount = 1
        Highlight 0, True
        End If
      For xLong1 = xCount To Count - 1
        'ePic(xLong1).Top = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (xLong1 - xPage) + xSpaceGen
        'eLabel(xLong1).Top = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (xLong1 - xPage) + xSpaceGen + xSpaceIHeight  '+ 40 '78 / + 8+32
        xLong3 = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (-xPage + xLong1) + xSpaceGen
        Load ePic(xLong1)
        With ePic(xLong1)
          .Top = xLong3
          'ePic(xLong1).TabStop = False
          .Visible = True
          End With
        Load eLabel(xLong1)
        With eLabel(xLong1)
          .Top = xLong3 + xSpaceIHeight
          .ForeColor = &H80000008
          .BackColor = &H80000005
          .Visible = True
          End With
        Next
      End If
    xCount = xLong2
    
    If xCount = 0 Then
      Highlight 0, False
      xCurrent = 0
      Else
      If Not xCurrent < xCount Then
        xCurrent = xCount - 1
        CurrentItem = xCurrent
        End If
      End If
    CheckPaging
  
  
    #Else



    Dim xLong1 As Long
    Dim xLong2 As Long
    
    ePic(xLong1).Top = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (-xPage) + xSpaceGen   '78
    eLabel(xLong1).Top = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (-xPage) + xSpaceGen + xSpaceIHeight   '+ 40 '78 / + 8+32
    ePic(0).Visible = Not Count = 0
    eLabel(0).Visible = Not Count = 0
    xCurrent = 0
    xCount = 1
    Highlight 0, True
    
    For xLong1 = 1 To Count - 1
      xLong2 = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (xLong1 - xPage) + xSpaceGen
      Load ePic(xLong1)
      'ePic(xLong1).Top = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (xLong1 - xPage) + xSpaceGen  '78
      With ePic(xLong1)
        .Top = xLong2
        .Visible = True
        End With
      Load eLabel(xLong1)
      'eLabel(xLong1).Top = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (xLong1 - xPage) + xSpaceGen + xSpaceIHeight  '+ 40 '78 / + 8+32
      With eLabel(xLong1)
        .Top = xLong2 + xSpaceIHeight
        .ForeColor = &H80000008
        .BackColor = &H80000005
        .Visible = True
        End With
      Next
    xCount = Count
    
    If Not xCurrent < xCount Then
      xCurrent = xCount - 1
      ''''CurrentItem = xCurrent
      End If
    CheckPaging
    
    #End If
  End Property

#If ctMenuA_Flag_AddRemoveItemA Or ctMenuA_Flag_AddItemA Then
  Public Sub AddItem(ByVal Index As Long)
    Dim xLong1 As Long
    Dim xLong2 As Long
    Dim xChar1 As String
    
    #If ctMenuA_Flag_Keys Then
      If xCount = xMaxCount Then
        Exit Sub
        End If
      #End If
    If Index < xCount + 1& Then
      If Not xCount = 0& Then
        Load ePic(xCount)
        Load eLabel(xCount)
        End If
      xLong1 = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (xCount - xPage) + xSpaceGen
      ePic(xCount).Top = xLong1
      eLabel(xCount).Top = xLong1 + xSpaceIHeight
      For xLong1 = xCount To Index + 1& Step -1&
        xLong2 = xLong1 - 1&
        xChar1 = ePic(xLong2).ToolTipText
        ePic(xLong1).Picture = ePic(xLong2).Picture
        ePic(xLong1).ToolTipText = xChar1
        eLabel(xLong1).Caption = eLabel(xLong2).Caption
        eLabel(xLong1).ToolTipText = xChar1
        #If ctMenuA_Flag_Keys Then
          xKey(xLong1) = xKey(xLong2)
          #End If
        Next
      xCount = xCount + 1&
      Highlight xCount - 1&, False
      If Not xCurrent < Index Then
        Highlight xCurrent, False
        xCurrent = xCurrent + 1&
        Highlight xCurrent, True
        End If
      ePic(xCount - 1&).Visible = True
      eLabel(xCount - 1&).Visible = True
      CheckPaging
      End If
    End Sub
  #End If

#If ctMenuA_Flag_AddRemoveItemA Or ctMenuA_Flag_RemoveItemA Then
  Public Sub RemoveItem(ByVal Index As Long)
    Dim xLong1 As Long
    Dim xLong2 As Long
    Dim xChar1 As String
    
    If Index < xCount Then
      For xLong1 = Index To xCount - 2&
        xLong2 = xLong1 + 1&
        xChar1 = ePic(xLong1 - 1&).ToolTipText
        ePic(xLong1).Picture = ePic(xLong2).Picture
        ePic(xLong1).ToolTipText = xChar1
        eLabel(xLong1).Caption = eLabel(xLong2).Caption
        eLabel(xLong1).ToolTipText = xChar1
        #If ctMenuA_Flag_Keys Then
          xKey(xLong1) = xKey(xLong2)
          #End If
        Next
      If xCount = 1& Then
        ePic(0).Visible = False
        eLabel(0).Visible = False
        Else
        Unload ePic(xCount - 1&)
        Unload eLabel(xCount - 1&)
        If xCurrent > Index Then
          If Not xCurrent = xCount - 1& Then
            Highlight xCurrent, False
            End If
          xCurrent = xCurrent - 1&
          Highlight xCurrent, True
          ElseIf xCurrent = Index Then
          Highlight xCurrent, True
          End If
        End If
      xCount = xCount - 1&
      CheckPaging
      End If
    End Sub
  #End If


Public Sub SetItem(ByVal Index As Long, ByVal Caption As String, ByVal PictureResID As Long, Optional ByVal ToolTipText As String = "")
If Index < xCount Then
  eLabel(Index).Caption = Caption
  On Error Resume Next
  ePic(Index).Picture = LoadResPicture(PictureResID, 1)
  On Error GoTo 0
  ePic(Index).ToolTipText = ToolTipText
  eLabel(Index).ToolTipText = ToolTipText
  End If
End Sub

Private Sub eButton_Click(Index As Integer)
If Index = 0 And Not xPage = 0 Then SetPage xPage - 1, False
If Index = 1 And Not xPage = xCount - xPages Then SetPage xPage + 1, False
End Sub

Private Sub eLabel_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
ClickEvent Index
End Sub

Private Sub ePic_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
ClickEvent Index
End Sub

Private Sub ClickEvent(ByVal Index As Long)
If Not Index = xCurrent Then
  Highlight xCurrent, False
  Highlight Index, True
  xCurrent = Index
  End If
RaiseEvent ItemClick(Index)
End Sub

#If ctMenuA_Flag_SetCurItem Then
  Public Property Let CurrentItem(ByVal Index As Long)
    If Not Index = xCurrent And Index < xCount Then
      Highlight xCurrent, False
      xCurrent = Index
      Highlight xCurrent, True
      RaiseEvent ItemClick(Index)
      End If
    End Property
  #End If

#If ctMenuA_Flag_GetCurItem Then
  Public Property Get CurrentItem() As Long
    CurrentItem = xCurrent
    End Property
  #End If
  


Private Sub Highlight(ByVal Index As Long, ByVal Highlight As Boolean)
If Highlight Then
  If xHasFocus Then
    eLabel(Index).ForeColor = &H8000000E
    eLabel(Index).BackColor = &H8000000D
    Else
    eLabel(Index).ForeColor = &H80000012
    eLabel(Index).BackColor = &H8000000F
    End If
  If xPages < 3 Or Index = 0 Or Index = xCount - 1 Then
    If Index < xPage Then SetPage Index, False
    If Index > xPage + xPages - 1 And Not xPages = 0 Then SetPage Index + 1 - xPages, False
    Else
    If Index < xPage + 1 Then SetPage Index - 1, False
    If Index > xPage + xPages - 2 And Not xPages = 0 Then SetPage (Index + 2 - xPages), False
    End If
  Else
  eLabel(Index).ForeColor = &H80000008
  eLabel(Index).BackColor = &H80000005
  End If
End Sub

Private Sub UserControl_EnterFocus()
xHasFocus = True
Highlight xCurrent, True
End Sub

Private Sub UserControl_ExitFocus()
xHasFocus = False
Highlight xCurrent, True
End Sub

Private Sub UserControl_Initialize()
xSpaceTHeight = 16
xSpaceGen = 16
xSpaceIHeight = 32
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 38 And Not xCount = 0 And Not xCurrent = 0 Then
  ClickEvent xCurrent - 1
  End If
If KeyCode = 40 And Not xCount = 0 And Not xCurrent = xCount - 1 Then
  ClickEvent xCurrent + 1
  End If
End Sub

Private Sub UserControl_Resize()
Dim xLong1 As Long
Dim xLong2 As Long

CheckPaging
xLong2 = UserControl.ScaleWidth
If xCount = 0 Then
  ePic(0).Left = (xLong2 - xSpaceIHeight) / 2
  eLabel(0).Left = xSpaceTLeft
  eLabel(0).Width = xLong2 - xSpaceTWidth
  Else
  For xLong1 = 0 To xCount - 1
    ePic(xLong1).Left = (xLong2 - xSpaceIHeight) / 2
    eLabel(xLong1).Left = xSpaceTLeft
    eLabel(xLong1).Width = xLong2 - xSpaceTWidth
    Next
  End If

eButton(0).Top = xSpaceBTop
xLong2 = xLong2 - eButton(0).Width - xSpaceBRight
'eButton(0).Left = xLong2 - eButton(0).Width - xSpaceBRight
'eButton(1).Left = xLong2 - eButton(1).Width - xSpaceBRight
eButton(0).Left = xLong2
eButton(1).Left = xLong2
eButton(1).Top = UserControl.ScaleHeight - eButton(1).Height - xSpaceBBottom
End Sub

Private Sub CheckPaging()
Dim xLong1 As Long

xLong1 = (UserControl.ScaleHeight - xSpaceTHeight) \ (xSpaceTHeight + xSpaceGen + xSpaceIHeight)
If xLong1 > xCount Then
  xPages = xCount
  Else
  If xLong1 < 1 Then
    xPages = 1
    Else
    xPages = xLong1
    End If
  End If

If xPages < xCount Then
  If xPage + xPages > xCount Then
    SetPage xCount - xPages, False
    End If
  Else
  SetPage 0, False
  End If

eButton(0).Visible = (Not xPage = 0)
If xCount = 0 Then
  eButton(1).Visible = False
  Else
  eButton(1).Visible = (Not xPage = xCount - xPages)
  End If
End Sub

Private Sub SetPage(ByVal Page As Long, ByVal Force As Boolean)
Dim xLong1 As Long
Dim xLong2 As Long

If Not Page = xPage Or Force Then
  xPage = Page
  For xLong1 = 0 To xCount - 1
    'ePic(xLong1).Top = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (xLong1 - xPage) + xSpaceGen '78
    'eLabel(xLong1).Top = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (xLong1 - xPage) + xSpaceGen + xSpaceIHeight '+ 40 '78 / + 8+32
    xLong2 = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (xLong1 - xPage) + xSpaceGen '78
    ePic(xLong1).Top = xLong2
    eLabel(xLong1).Top = xLong2 + xSpaceIHeight
    Next
  End If
eButton(0).Visible = (Not xPage = 0)
If xCount = 0 Then
  eButton(1).Visible = False
  Else
  eButton(1).Visible = (Not xPage = xCount - xPages)
  End If
End Sub

#If ctMenuA_Flag_SetTextHeight Then
  Public Property Let TextHeight(ByVal Height As Long)
    If Not xSpaceTHeight = Height Then
      xSpaceTHeight = Height
      UserControl_Resize
      CheckPaging
      End If
    End Property
  #End If

#If ctMenuA_Flag_FlatButtons Or ctMenuA_Flag_FlatButtonsEx Then
  Public Property Let FlatButtons(ByVal NewValue As Boolean)
    Dim xLong1 As Long
    
    If Not xFlButtons = NewValue Then
      xFlButtons = NewValue
      If xFlButtons Then
        xLong1 = eButton(0).hwnd
        Call SetWindowLongA(xLong1, -16, GetWindowLongA(xLong1, -16) Or &H8000&)
        eButton(0).Refresh
        xLong1 = eButton(1).hwnd
        Call SetWindowLongA(xLong1, -16, GetWindowLongA(xLong1, -16) Or &H8000&)
        eButton(1).Refresh
        Else
        xLong1 = eButton(0).hwnd
        Call SetWindowLongA(xLong1, -16, GetWindowLongA(xLong1, -16) And Not &H8000&)
        eButton(1).Refresh
        xLong1 = eButton(0).hwnd
        Call SetWindowLongA(xLong1, -16, GetWindowLongA(xLong1, -16) And Not &H8000&)
        eButton(1).Refresh
        End If
      End If
    End Property
  #End If








' Especially designed for speed/size issues for QuickTask, this procedure adds / removes last item (1 item)
' No key support
' Always (Un)selects last item as used for QuickTask only
#If ctMenuA_Flag_AddRemoveItemExQT Then
  Public Sub AddItemExQT()
    Dim xLong1 As Long
    Load ePic(xCount)
    Load eLabel(xCount)
    xLong1 = (xSpaceTHeight + xSpaceGen + xSpaceIHeight) * (xCount - xPage) + xSpaceGen
    ePic(xCount).Top = xLong1
    eLabel(xCount).Top = xLong1 + xSpaceIHeight
    Highlight xCurrent, False
    xCurrent = xCount
    xCount = xCount + 1&
    Highlight xCurrent, True
    ePic(xCount - 1&).Visible = True
    eLabel(xCount - 1&).Visible = True
    CheckPaging
    End Sub
  
  Public Sub RemoveItemExQT()
    Unload ePic(xCount - 1&)
    Unload eLabel(xCount - 1&)
    xCount = xCount - 1&
    xCurrent = xCount - 1&
    Highlight xCurrent, True
    CheckPaging
    End Sub
  #End If
