vbAccelerator - Contents of code file: frmTestPaneSelector.frm

VERSION 5.00
Object = "{CB4519CB-F566-458B-B3A5-DD47FD8A54EE}#1.0#0"; "vbalPaneSelector.ocx"
Object = "{3D811CB0-6F63-4CA8-BD1E-7858AC6C9A00}#5.6#0"; "vbalSGrid.ocx"
Begin VB.Form frmTestPaneSelector 
   Caption         =   "vbAccelerator SGrid Pane Selection Demonstration"
   ClientHeight    =   7080
   ClientLeft      =   4020
   ClientTop       =   3495
   ClientWidth     =   6585
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmTestPaneSelector.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   7080
   ScaleWidth      =   6585
   Begin VB.PictureBox picRender 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   3435
      Left            =   60
      ScaleHeight     =   3405
      ScaleWidth      =   3525
      TabIndex        =   6
      TabStop         =   0   'False
      Top             =   1080
      Width           =   3555
   End
   Begin VB.PictureBox picIconInfo 
      BorderStyle     =   0  'None
      Height          =   975
      Left            =   60
      ScaleHeight     =   975
      ScaleWidth      =   3555
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   60
      Width           =   3555
      Begin VB.ComboBox cboDeviceImages 
         Height          =   315
         Left            =   1200
         Sorted          =   -1  'True
         Style           =   2  'Dropdown List
         TabIndex        =   5
         Top             =   600
         Width           =   1995
      End
      Begin VB.TextBox txtSize 
         BackColor       =   &H8000000F&
         BorderStyle     =   0  'None
         Height          =   285
         Left            =   1200
         Locked          =   -1  'True
         TabIndex        =   3
         Text            =   " "
         Top             =   300
         Width           =   1995
      End
      Begin VB.Label lblDeviceImage 
         Caption         =   "Device Images:"
         Height          =   195
         Left            =   0
         TabIndex        =   4
         Top             =   660
         Width           =   1215
      End
      Begin VB.Label lblSize 
         Caption         =   "Size on Disk:"
         Height          =   195
         Left            =   0
         TabIndex        =   2
         Top             =   300
         Width           =   1215
      End
      Begin VB.Label lblIconFile 
         BackColor       =   &H80000010&
         Caption         =   " "
         ForeColor       =   &H80000014&
         Height          =   255
         Left            =   0
         TabIndex        =   1
         Top             =   0
         Width           =   3075
      End
   End
   Begin VB.PictureBox picParent 
      BackColor       =   &H80000010&
      BorderStyle     =   0  'None
      Height          =   4455
      Left            =   3660
      ScaleHeight     =   4455
      ScaleWidth      =   2835
      TabIndex        =   7
      TabStop         =   0   'False
      Top             =   60
      Width           =   2835
      Begin vbalPaneSelectorLib.vbalPaneSelector paneSelector 
         Height          =   615
         Left            =   300
         Top             =   180
         Width           =   1395
         _ExtentX        =   2461
         _ExtentY        =   1085
      End
      Begin vbAcceleratorSGrid.vbalGrid grdIcons 
         Height          =   3855
         Left            =   60
         TabIndex        =   8
         Top             =   300
         Width           =   2655
         _ExtentX        =   4683
         _ExtentY        =   6800
         BackgroundPictureHeight=   0
         BackgroundPictureWidth=   0
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         BorderStyle     =   0
         DisableIcons    =   -1  'True
      End
   End
   Begin VB.Menu mnuFileTOP 
      Caption         =   "&File"
      Begin VB.Menu mnuFile 
         Caption         =   "E&xit"
         Index           =   0
      End
   End
   Begin VB.Menu mnuHelpTOP 
      Caption         =   "&Help"
      Begin VB.Menu mnuHelp 
         Caption         =   "&About..."
         Index           =   0
      End
   End
   Begin VB.Menu mnuPaneTOP 
      Caption         =   ""
      Visible         =   0   'False
      Begin VB.Menu mnuPane 
         Caption         =   "&Open"
         Index           =   0
      End
      Begin VB.Menu mnuPane 
         Caption         =   "-"
         Index           =   1
      End
      Begin VB.Menu mnuPane 
         Caption         =   "&Delete..."
         Index           =   2
      End
   End
End
Attribute VB_Name = "frmTestPaneSelector"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type
Private Declare Function DrawTextA Lib "user32" (ByVal hDC As Long, ByVal lpStr
 As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private m_cIml As cVBALSysImageList
Private m_iCol As Long
Private m_iRow As Long
Private m_bShowingMenu As Boolean
Private m_cFI As cFileIcon

Implements IGridCellOwnerDraw

Private Sub openIcon(ByVal sIcon As String)
Dim i As Long
Dim sText As String
   Set m_cFI = New cFileIcon
   cboDeviceImages.Clear
   If m_cFI.LoadIcon(sIcon) Then
      lblIconFile.Caption = " " & fileNameOf(sIcon)
      For i = 1 To m_cFI.ImageCount
         sText = m_cFI.ImageWidth(i) & " x " & m_cFI.ImageHeight(i)
         sText = sText & " " & m_cFI.ImageBitCount(i) & "bpp"
         cboDeviceImages.AddItem sText
         cboDeviceImages.ItemData(cboDeviceImages.NewIndex) = i
      Next i
      cboDeviceImages.ListIndex = 0
   Else
      lblIconFile.Caption = ""
   End If
   txtSize.Text = Format(FileLen(sIcon), "#,##0") & " bytes"
End Sub

Private Sub addIcon(ByVal sIcon As String)
   
   ' Choose where to place the item
   If (m_iCol = 0) Then
      grdIcons.AddRow
      m_iRow = m_iRow + 1
      m_iCol = 1
   Else
      m_iCol = 2
   End If
   
   ' Add the item:
   grdIcons.CellDetails m_iRow, m_iCol, _
      sIcon, _
      DT_SINGLELINE Or DT_CENTER Or DT_PATH_ELLIPSIS, _
      lIconIndex:=m_cIml.ItemIndex(sIcon)

   ' Prepare for next row
   If (m_iCol = 2) Then
      m_iCol = 0
   End If

End Sub

Private Sub loadIcons(ByVal sPath As String)
Dim sDir As String
Dim colDirs As New Collection
Dim colIcons As New Collection
Dim sBasePath As String
Dim vItem As Variant
   
   If Not (right(sPath, 1) = "") Then
      sBasePath = sPath & "\"
   Else
      sBasePath = sPath
   End If
   
   sDir = Dir(sBasePath & "*.*", vbDirectory)
   Do While Len(sDir) > 0
      If Not (sDir = ".") And Not (sDir = "..") Then
         If (GetAttr(sBasePath & sDir) And vbDirectory) = vbDirectory Then
            colDirs.Add sBasePath & sDir
         End If
      End If
      sDir = Dir
   Loop
   
   For Each vItem In colDirs
      loadIcons vItem
   Next
   
   sDir = Dir(sBasePath & "*.ico")
   Do While Len(sDir) > 0
      If (GetAttr(sBasePath & sDir) And vbDirectory) = 0 Then
         colIcons.Add sBasePath & sDir
      End If
      sDir = Dir
   Loop

   For Each vItem In colIcons
      addIcon vItem
   Next

End Sub

Private Sub configureGrid()

   ' Set up Image List:
   Set m_cIml = New cVBALSysImageList
   With m_cIml
      .IconSizeX = 32
      .IconSizeY = 32
      .Create
   End With
   
   With grdIcons
      
      .Header = False
      .DefaultRowHeight = 32 + 6 + 24
      .SelectionAlphaBlend = True
      .SelectionOutline = True
      .DrawFocusRectangle = False
      .HighlightForeColor = vbWindowText
      .HotTrack = True
      .RowTextStartColumn = 1
      
      .AddColumn "1", "1", lColumnWidth:=96
      .AddColumn "2", "2", lColumnWidth:=96
      
      .ImageList = m_cIml.hIml
      .HeaderImageList = 0
      
      .OwnerDrawImpl = Me
      
   End With
   
End Sub

Private Sub cboDeviceImages_Click()
   picRender.Cls
   If Not (m_cFI Is Nothing) Then
      
      Dim lAvailWidth As Long
      Dim lAvailHeight As Long
      lAvailWidth = picRender.ScaleWidth \ Screen.TwipsPerPixelX
      lAvailHeight = picRender.ScaleHeight \ Screen.TwipsPerPixelY
      
      ' Calculate zoom:
      Dim lOrigWidth As Long
      Dim lOrigHeight As Long
      Dim lWidth As Long
      Dim lHeight As Long
      Dim lZoom As Long
      Dim bDone As Boolean
      Dim lIndex As Long
      Dim lX As Long
      Dim lY As Long
      
      lIndex = cboDeviceImages.ItemData(cboDeviceImages.ListIndex)
      lOrigWidth = m_cFI.ImageWidth(lIndex)
      lOrigHeight = m_cFI.ImageHeight(lIndex)
      lWidth = lOrigWidth
      lHeight = lOrigHeight
      lZoom = 1
      Do While Not (bDone)
         If (lOrigWidth * lZoom > lAvailWidth) Or (lOrigHeight * lZoom >
          lAvailHeight) Then
            bDone = True
         Else
            lWidth = lOrigWidth * lZoom
            lHeight = lOrigHeight * lZoom
            lZoom = lZoom + 1
         End If
      Loop
      lX = (lAvailWidth - lWidth) \ 2
      lY = (lAvailHeight - lHeight) \ 2
      
      m_cFI.DrawIconImage picRender.hDC, lIndex, , lX, lY, lWidth, lHeight
      
   End If
   picRender.Refresh
End Sub

Private Sub Form_Load()
Dim sInitPath As String

   sInitPath = App.Path
   If (right(sInitPath, 1) <> "\") Then
      sInitPath = sInitPath & "\"
   End If
   sInitPath = sInitPath & "Icons"
   
   configureGrid
   loadIcons sInitPath
   
End Sub

Private Sub Form_Resize()
   
   On Error Resume Next
   
   Dim lHeight As Long
   Dim lRowHeight As Long
   Dim lRows As Long
   Dim lWidth As Long
   
   lHeight = Me.ScaleHeight - picParent.top * 2 - 2 * Screen.TwipsPerPixelY
   lRowHeight = (grdIcons.DefaultRowHeight * Screen.TwipsPerPixelY)
   lHeight = (lHeight \ lRowHeight) * lRowHeight + 2 * Screen.TwipsPerPixelY
   lWidth = (4 + grdIcons.ColumnWidth(1) + grdIcons.ColumnWidth(2) + 15) *
    Screen.TwipsPerPixelX
   picParent.Move _
      Me.ScaleWidth - lWidth - 4 * Screen.TwipsPerPixelY, picParent.top, _
      lWidth, _
      lHeight
   picIconInfo.Move picIconInfo.left, picIconInfo.top, _
      Me.ScaleWidth - picIconInfo.left - lWidth - 8 * Screen.TwipsPerPixelX
   picRender.Move picRender.left, picRender.top, _
      picIconInfo.Width, Me.ScaleHeight - picRender.top - 4 *
       Screen.TwipsPerPixelY
   
End Sub


Private Sub grdIcons_HotItemChange(ByVal lRow As Long, ByVal lCol As Long)
   If (m_bShowingMenu) Then
      Exit Sub
   End If
   If (lRow > 0) And (lCol > 0) Then
      Dim lLeft As Long
      Dim lTop As Long
      Dim lWidth As Long
      Dim lHeight As Long
      grdIcons.CellBoundary lRow, lCol, lLeft, lTop, lWidth, lHeight
      If (lTop < 0) Then
         Debug.Print "Top < 0", lLeft, lTop, lWidth, lHeight
      End If
      If (grdIcons.top + lTop < 0) Then
         paneSelector.Visible = False
      Else
         paneSelector.Move _
            grdIcons.left + IIf(lCol = 2, grdIcons.ColumnWidth(1) *
             Screen.TwipsPerPixelX, 0), _
            grdIcons.top + lTop, _
            grdIcons.ColumnWidth(1) * Screen.TwipsPerPixelX, _
            lHeight
         If Not (paneSelector.Visible) Then
            paneSelector.Visible = True
         End If
      End If
      paneSelector.ZOrder
   Else
      paneSelector.Visible = False
   End If
End Sub

Private Sub grdIcons_MouseUp(Button As Integer, Shift As Integer, x As Single,
 y As Single)
Dim lRow As Long
Dim lCol As Long
   lRow = grdIcons.SelectedRow
   lCol = grdIcons.SelectedCol
   If (lRow > 0) And (lCol > 0) Then
      openIcon grdIcons.CellText(lRow, lCol)
   End If
End Sub

Private Sub grdIcons_ScrollChange(ByVal eBar As
 vbAcceleratorSGrid.ECGScrollBarTypes)
   '
   grdIcons_HotItemChange grdIcons.HotRow, grdIcons.HotCol
   '
End Sub

Private Sub IGridCellOwnerDraw_Draw(cell As vbAcceleratorSGrid.cGridCell, ByVal
 lHDC As Long, ByVal eDrawStage As vbAcceleratorSGrid.ECGDrawStage, ByVal lLeft
 As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long,
 bSkipDefault As Boolean)
   '
   If (eDrawStage = ecgBeforeIconAndText) Then
      '
      bSkipDefault = True
      
      ' Draw icon
      Dim lIconX As Long
      Dim lIconY As Long
      lIconY = lTop + 2
      lIconX = lLeft + (lRight - lLeft - m_cIml.IconSizeX) \ 2
      m_cIml.DrawImage cell.Text, lHDC, lIconX, lIconY
      
      ' Draw text
      Dim rc As RECT
      rc.left = lLeft + 1
      rc.right = lRight - 1
      rc.top = m_cIml.IconSizeY + 4
      rc.bottom = lBottom - 1
      DrawTextA lHDC, fileNameOf(cell.Text), -1, rc, cell.TextAlign
      
      '
   End If
   '
End Sub

Private Function fileNameOf(ByVal sFile As String) As String
Dim i As Long
   For i = Len(sFile) To 1 Step -1
      If (Mid(sFile, i, 1) = "\") Then
         fileNameOf = Mid(sFile, i + 1)
         Exit Function
      End If
   Next i
   fileNameOf = sFile
End Function


Private Sub mnuFile_Click(Index As Integer)
   Select Case Index
   Case 0
      Unload Me
   End Select
End Sub

Private Sub mnuHelp_Click(Index As Integer)
   Select Case Index
   Case 0
      Dim fA As New frmAbout
      fA.Show vbModal, Me
   End Select
End Sub

Private Sub mnuPane_Click(Index As Integer)
Dim lRow As Long
Dim lCol As Long
Dim iPos As Long
   
   iPos = InStr(mnuPaneTOP.Tag, ":")
   lRow = CLng(left(mnuPaneTOP.Tag, iPos - 1))
   lCol = CLng(Mid(mnuPaneTOP.Tag, iPos + 1))
      
   grdIcons.SelectedCol = lCol
   grdIcons.SelectedRow = lRow
   
   Select Case Index
   Case 0
      ' "Open" icon here
      openIcon grdIcons.CellText(lRow, lCol)
   Case 2
      ' "Delete" icon here
      MsgBox "Would allow deletion of icon " & grdIcons.CellText(lRow, lCol) &
       " here.", vbInformation
   End Select
   
End Sub

Private Sub paneSelector_Click()
   '
   Dim x As Single
   Dim y As Single
   x = paneSelector.left + paneSelector.Width + picParent.left
   y = paneSelector.top + paneSelector.Height + picParent.top
   mnuPaneTOP.Tag = grdIcons.HotRow & ":" & grdIcons.HotCol
   m_bShowingMenu = True
   Me.PopupMenu mnuPaneTOP, vbPopupMenuRightAlign, x, y
   m_bShowingMenu = False
   '
End Sub

Private Sub picIconInfo_Resize()
On Error Resume Next
   lblIconFile.Width = picIconInfo.ScaleWidth
   txtSize.Width = picIconInfo.ScaleWidth - txtSize.left - 2 *
    Screen.TwipsPerPixelX
   cboDeviceImages.Width = txtSize.Width
End Sub

Private Sub picParent_Resize()
On Error Resume Next
   grdIcons.Move Screen.TwipsPerPixelX, Screen.TwipsPerPixelY, _
      picParent.ScaleWidth - Screen.TwipsPerPixelX * 2, _
      picParent.ScaleHeight - Screen.TwipsPerPixelY * 2
End Sub

Private Sub picRender_Resize()
   cboDeviceImages_Click
End Sub