Option Explicit
Dim InboxFolder As Long
Dim OutboxFolder As Long
Dim SavedFolder As Long
Dim DeletedFolder As Long
Private Function AddFolder(ByVal Folder As String, ByVal Desc As String, ByVal Count As Integer)
Dim ItemIndex As Long
With SftTree1
ItemIndex = .Items.Add(Folder) ' add folder
.Cell(ItemIndex, 1).Text = Desc ' add description
.Cell(ItemIndex, 3).Text = Count ' add number of messages
.Cell(ItemIndex, 3).Data = Count ' also save number of messages for sorting
' make the folder name bold
.Cell(ItemIndex, 0).Font.Bold = True
' if this folder has no messages (ie. dependents), we still want the
' folder graphic, not the email (leaf) graphic
If Count = 0 Then
.Item(ItemIndex).Image = .Items.ItemImageExpandable
End If
AddFolder = .Item(ItemIndex).ID
End With
End Function
Private Function AddMessage(ByVal Level As Integer, ByVal Email As String, ByVal Desc As String, ByVal Dt As String, ByVal Size As Integer, ByVal Attachment As Boolean)
Dim ItemIndex As Long
With SftTree1
ItemIndex = .Items.Add(Email) ' add folder
.Item(ItemIndex).Level = Level
.Cell(ItemIndex, 1).Text = Desc ' add description
.Cell(ItemIndex, 2).Text = Dt ' add date
.Cell(ItemIndex, 3).Text = Size & "K"
.Cell(ItemIndex, 3).Data = Size ' also save size for sorting
' if this email has replies (ie. dependents), we still want the
' email graphic, not the expand folder image
.Item(ItemIndex).Image = .Items.ItemImageLeaf
' if the email has an attachment, show the image
If Attachment Then
Set .Cell(ItemIndex, 1).Image.Picture = Attach.Picture
.Cell(ItemIndex, 1).ImageHAlign = halignSftTreeRight
End If
End With
End Function
Private Sub Command1_Click()
End
End Sub
Private Sub Form_Load()
With SftTree1
InboxFolder = AddFolder("Inbox", "Viewed and unviewed mail", 10)
AddMessage 1, "support@softelvdm.com", "Re: A support question", "10/09/05", 88, True
AddMessage 1, "anyone@acompany.com", "Re: Why did you say that", "10/10/05", 5, False
AddMessage 1, "anyone@acompany.com", "Re: You're fired", "10/11/05", 82, True
AddMessage 1, "anyone@acompany.com", "Re: You're hired", "10/11/05", 6, False
.Item(.Items.ItemIndex(InboxFolder)).Collapse False
OutboxFolder = AddFolder("Outbox", "Mail about to be sent", 2)
AddMessage 1, "me@mycompany.com", "Re: You're fired", "10/11/05", 5, False
AddMessage 1, "anyone@acompany.com", "Re: Why did you say that", "10/10/05", 5, False
.Item(.Items.ItemIndex(OutboxFolder)).Collapse False
SavedFolder = AddFolder("Saved", "Saved messages", 2)
AddMessage 1, "me@mycompany.com", "A support question", "10/09/05", 3, False
AddMessage 2, "support@softelvdm.com", "Re: A support question", "10/09/05", 88, True
AddMessage 3, "me@mycompany.com", "Re: A support question", "10/09/05", 3, False
AddMessage 1, "me@mycompany.com", "Why did you say that", "10/06/05", 5, False
AddMessage 2, "anyone@acompany.com", "Re: Why did you say that", "10/10/05", 5, False
AddMessage 1, "me@mycompany.com", "You're fired", "10/08/05", 2, False
AddMessage 2, "anyone@acompany.com", "Re: You're fired", "10/11/05", 82, False
AddMessage 1, "me@mycompany.com", "You're hired", "10/01/05", 4, False
AddMessage 1, "anyone@acompany.com", "Re: You're hired", "10/11/05", 6, False
.Item(.Items.ItemIndex(SavedFolder)).Collapse False
DeletedFolder = AddFolder("Deleted", "Deleted messages", 0)
.ColumnsObj.MakeOptimal
.Items.RecalcHorizontalExtent
.Splitter.MakeOptimal
' clear column header pictures
.Header(1).Image.Clear
.Header(2).Image.Clear
.Header(3).Image.Clear
.Items.Current = 0
SftTree1_CaretChange 0 ' to update column headers
End With
End Sub
Private Sub SftTree1_CaretChange(ByVal ItemIndex As Long)
With SftTree1
' set column headers based on selected item
Select Case .Item(ItemIndex).ID
Case InboxFolder, OutboxFolder, SavedFolder, DeletedFolder
.Header(0).Text = "Folder"
.Header(1).Text = "Description"
.Header(2).Text = "" ' we can use this to merge the adjacent title
.Header(3).Text = "Msgs"
Case Else
.Header(0).Text = "From"
.Header(1).Text = "Subject"
.Header(2).Text = "Received"
.Header(3).Text = "Size"
End Select
End With
End Sub
Private Sub SftTree1_ItemClick(ByVal ItemIndex As Long, ByVal ColIndex As Integer, ByVal AreaType As Integer, ByVal Button As Integer, ByVal Shift As Integer)
Dim Ascending As Boolean
With SftTree1
If AreaType = constSftTreeButton Then
If .Item(ItemIndex).Expanded Then
.Item(ItemIndex).Collapse True
Else
.Item(ItemIndex).Expand True, False
End If
ElseIf AreaType = constSftTreeText Then
' edit description
If ColIndex = 1 Then
.Cell(ItemIndex, ColIndex).Edit 0, 0
End If
ElseIf AreaType = constSftTreeColumnHeader Then
Ascending = True
If .Header(ColIndex).Image.Appearance = sftImageSortAsc Then
Ascending = False
End If
' we have to sort based on current column headers
' we saved a value in Item.Data telling us if it's a folder
Select Case .Item(.Items.Current).ID
Case InboxFolder, OutboxFolder, SavedFolder, DeletedFolder
' we're on a folder, so sort on folder level
If Ascending Then
If ColIndex = 3 Then
' last column is sorted by Cell.Data (numeric values)
.Items.SortDependents -1, ColIndex, sortSftTreeAscCellItemData
Else
.Items.SortDependents -1, ColIndex, sortSftTreeAscending
End If
Else
If ColIndex = 3 Then
.Items.SortDependents -1, ColIndex, sortSftTreeDscCellItemData
Else
.Items.SortDependents -1, ColIndex, sortSftTreeDescending
End If
End If
Case Else
' we're on a message, sort inside folders
' now sort the dependents of all folders
ItemIndex = 0
Do
If Ascending Then
If ColIndex = 3 Then
' last column is sorted by Cell.Data (numeric values)
.Items.SortDependents ItemIndex, ColIndex, sortSftTreeAscCellItemData
Else
.Items.SortDependents ItemIndex, ColIndex, sortSftTreeAscending
End If
Else
If ColIndex = 3 Then
.Items.SortDependents ItemIndex, ColIndex, sortSftTreeDscCellItemData
Else
.Items.SortDependents ItemIndex, ColIndex, sortSftTreeDescending
End If
End If
ItemIndex = .Item(ItemIndex).NextSibling
Loop Until ItemIndex < 0
End Select
' change column header image
.Header(0).Image.Clear
.Header(1).Image.Clear
.Header(2).Image.Clear
.Header(3).Image.Clear
If Ascending Then
.Header(ColIndex).Image.Appearance = sftImageSortAsc
Else
.Header(ColIndex).Image.Appearance = sftImageSortDesc
End If
' update column headers by calling CaretChange
SftTree1_CaretChange .Items.Current
End If
End With
End Sub
Private Sub SftTree1_ItemDblClick(ByVal ItemIndex As Long, ByVal ColIndex As Integer, ByVal AreaType As Integer, ByVal Button As Integer, ByVal Shift As Integer)
With SftTree1
If AreaType = constSftTreeText Or AreaType = constSftTreeButton Then
' if an item on level 1 or lower is clicked, it's an
' email message, display message box
If .Item(ItemIndex).Level > 0 And AreaType = constSftTreeText Then
MsgBox ("You could be viewing the message from " & .Cell(ItemIndex, 0).Text & _
" with the subject '" & .Cell(ItemIndex, 1).Text & "'.")
Else
' otherwise just expand or collapse the item
If .Item(ItemIndex).Expanded Then
.Item(ItemIndex).Collapse True
Else
.Item(ItemIndex).Expand True, False
End If
End If
ElseIf AreaType = constSftTreeColumnRes Then
If ColIndex >= 0 Then
.Column(ColIndex).MakeOptimal
.Items.RecalcHorizontalExtent
Else
.Splitter.MakeOptimal
End If
End If
End With
End Sub
Private Sub SftTree1_EditAllowed(ByVal ItemIndex As Long, ByVal ColIndex As Integer, Allowed As Boolean)
' Only allow editing in column 1
If ColIndex = 1 Then
Allowed = True
Else
Allowed = False
End If
End Sub
Private Sub SftTree1_EditInitializing(Window As stdole.OLE_HANDLE, vData As Variant, ByVal EditIndex As Long, ByVal EditCol As Integer, LeftPix As stdole.OLE_XPOS_PIXELS, TopPix As stdole.OLE_YPOS_PIXELS, WidthPix As stdole.OLE_XSIZE_PIXELS, HeightPix As stdole.OLE_YSIZE_PIXELS)
Dim TextHeight As Integer
' LeftPix/TopPix/WidthPix/HeightPix describes the current cell area
' we need to return the position and size needed for editing.
' In this example, we use the height of the control on the form
' and center it over the cell.
TextHeight = EditControl.Height / Screen.TwipsPerPixelX
TopPix = TopPix + (HeightPix - TextHeight) / 2
HeightPix = TextHeight
EditControl.Width = Width * Screen.TwipsPerPixelX
EditControl.Text = SftTree1.Cell(EditIndex, EditCol).Text
EditControl.SelStart = 0
EditControl.SelLength = 999
' Return the control's window handle
Window = EditControl.hWnd
' Define navigation keys
' VK_TAB
SftTree1.CellEditIntercept Asc(vbTab), cellEditInterceptSftTreeChar + cellEditInterceptSftTreeControlChar + cellEditInterceptSftTreeShiftChar
' VK_RETURN
SftTree1.CellEditIntercept Asc(vbCr), cellEditInterceptSftTreeChar + cellEditInterceptSftTreeControlChar + cellEditInterceptSftTreeShiftChar
' VK_HOME
SftTree1.CellEditIntercept 36, cellEditInterceptSftTreeControlChar
' VK_END
SftTree1.CellEditIntercept 35, cellEditInterceptSftTreeControlChar
' VK_UP
SftTree1.CellEditIntercept 38, cellEditInterceptSftTreeChar + cellEditInterceptSftTreeControlChar + cellEditInterceptSftTreeShiftChar
' VK_DOWN
SftTree1.CellEditIntercept 40, cellEditInterceptSftTreeChar + cellEditInterceptSftTreeControlChar + cellEditInterceptSftTreeShiftChar
End Sub
Private Sub SftTree1_EditNavigating(ByVal Key As Long, ByVal Shift As Integer, ByVal ItemIndex As Long, ByVal ColIndex As Integer)
' Process key pressed
SftTree1.EditNavigate Key, Shift
End Sub
Private Sub SftTree1_EditValidate(ByVal Window As stdole.OLE_HANDLE, ByVal vData As Variant, ByVal EditIndex As Long, ByVal EditCol As Integer, InputValid As Boolean)
' Validate the new cell contents
If EditControl.Text = "" Then
MsgBox ("Please enter a description.")
InputValid = False
End If
End Sub
Private Sub SftTree1_EditEnding(ByVal Window As stdole.OLE_HANDLE, ByVal vData As Variant, ByVal EditIndex As Long, ByVal EditCol As Integer, ByVal SaveInput As Boolean)
' Save the new cell contents
If SaveInput Then
SftTree1.Cell(EditIndex, EditCol).Text = EditControl.Text
End If
End Sub