Solved

Folders comparison using multicolumntreeview

Posted on 2006-10-30
24
897 Views
Last Modified: 2008-01-09
please give me the code which can list "two" specified folders details using the multicolumntreeview control as shown in the link.

http://www.vbaccelerator.com/home/VB/Code/Controls/TreeView/Multi-Column_TreeView_Control/article.asp

grade-A assured for the answer.

when two folders are specified, one multricolumntreeview control on left must show all folders and files.

similarly the control on rightside must show the details of the second folder.
0
Comment
Question by:expertfan
  • 10
  • 10
  • 4
24 Comments
 
LVL 22

Expert Comment

by:danaseaman
ID: 17839808
Download and install demo application at http://cyberactivex.com/download/UniSuite.exe

After installation navigate to "C:\CyberActiveX\UniSuite\UniTreeViewMC\DemoBackupClient\pUniBackupClient.vbp" and you will find code to populate VbAccelerator Multi Column Treeview with files and folders.


0
 
LVL 22

Expert Comment

by:danaseaman
ID: 17839810
Oops. Should be folder "C:\Program Files\CyberActiveX\UniSuite\UniTreeViewMC\DemoBackupClient\pUniBackupClient.vbp"
0
 
LVL 14

Expert Comment

by:Shiju Sasidharan
ID: 17839893
@expertfan
you mean two different controls
or one control with two Columns ?
0
 

Author Comment

by:expertfan
ID: 17840447
hello shijusn,

last time you did this for 'two list view controls', now i want this to be done on 'multicolumntreeview' of vbaccelerator.
0
 
LVL 14

Expert Comment

by:Shiju Sasidharan
ID: 17840906
same stuff needs to be done in multicolumntreeview?
or u simply need to populate folder details to two different columns of the control
Have you checked code given by  danaseaman ?
0
 

Author Comment

by:expertfan
ID: 17840931
hi danaseaman/shijusn,

yes, the same stuff in multicolumntreeview
i would not prefer to do installations, if you could kindly post just the code here it would be great !
0
 
LVL 14

Expert Comment

by:Shiju Sasidharan
ID: 17840947
i was not able to install that stuff. May be danaseaman could help you

>>on left must show all folders and files.
That means you simply wanted to list all the files and folders
not some sort of comparison as we did before. right ?

0
 

Author Comment

by:expertfan
ID: 17840971
shijusn,

i want the "same comparison" like you did before.....now

1. left side 'control' will show "first folders" subfolders list along with the timestamp as another column
2. right side 'control' will show 'second folders' subfolders list along with the timestamp as nother column

in both these list we need to mark the 'missing folders'.
0
 
LVL 14

Expert Comment

by:Shiju Sasidharan
ID: 17841002
hmm, experimenting with multicolumntreeview ...
0
 
LVL 22

Expert Comment

by:danaseaman
ID: 17841972
The code is quite large which is why I gave the link. There are several modules, a class to get System Imagelist icons, and of course the Form code. I can post it if you like but it will be huge.
0
 

Author Comment

by:expertfan
ID: 17841990
hi danaseaman,

please post, because to install s/w i need to get my managers approval and it takes hell lot of time and questions.
0
 
LVL 22

Expert Comment

by:danaseaman
ID: 17842135
Please note that this code will not work out of the box with VbAccelerator MultiColumn TreeView however the changes should be minimal. You will have to remove the Unicode portions and code that deals with virtual folders.

'Form code
'---------
Option Explicit

Private Declare Function GetLogicalDrives Lib "kernel32" () As Long

Dim m_SysIml            As New cVBALSysImageList
Dim cReg                As New cRegSearch
Dim bInit               As Boolean
Dim m_CodePage      As Long

Private Sub setupColumns()
   Dim cCol             As cCTreeViewColumn
   Dim sName            As String
   ' 'Desktop
   With tvMC
      With .Columns
         .Item(1).Width = 220
         'Use localized column names from Windows Shell32.DLL
         sName = GetResourceStringFromFile(8976) & " (" & GetResourceStringFromFile(4131) & ", " & GetResourceStringFromFile(4130) & ")"
         .Item(1).Text = sName
         'Size in Explorer is right aligned
         Set cCol = .Add("Size", GetResourceStringFromFile(8978), , 70, HdrTextALignRight)
         Set cCol = .Add("Modified", GetResourceStringFromFile(8980), , 80, HdrTextALignRight)
         Set cCol = .Add("Time", GetResourceStringFromFile(25, "Intl.Cpl"), , 50, HdrTextALignRight)
      End With
   End With
   With tvMC2
      With .Columns
         .Item(1).Width = 220
         'Use localized column names from Windows Shell32.DLL
         sName = GetResourceStringFromFile(8976) & " (" & GetResourceStringFromFile(4131) & ", " & GetResourceStringFromFile(4130) & ")"
         .Item(1).Text = sName
         'Size in Explorer is right aligned
         Set cCol = .Add("Size", GetResourceStringFromFile(8978), , 70, HdrTextALignRight)
         Set cCol = .Add("Modified", GetResourceStringFromFile(8980), , 80, HdrTextALignRight)
         Set cCol = .Add("Time", GetResourceStringFromFile(25, "Intl.Cpl"), , 50, HdrTextALignRight)
      End With
   End With
End Sub

Private Sub setupData()
   On Error GoTo ErrHandler
   Dim nodSub           As cCTreeViewNode
   Dim nod              As cCTreeViewNode
   Dim lIcon            As Long
   Dim sDisplayName     As String
   Dim sCSV             As String
   Dim sOutlookExpress  As String

   tvMC.ItemHeight = 19
   lIcon = m_SysIml.ItemIndex(GetWindowsDirectory)
   Set nod = tvMC.Nodes.Add(, , "\\Files", "My Files", lIcon, lIcon)
   AddSpecialFolder nod, CSIDL_DESKTOP, sCSV
   AddSpecialFolder nod, CSIDL_PERSONAL, sCSV
   AddSpecialFolder nod, CSIDL_FAVORITES, sCSV
   sOutlookExpress = cReg.Search(HKEY_CURRENT_USER, "Identities", "Store Root", VALUE_NAME)
   If Len(sOutlookExpress) Then 'Only add if we found it
      sOutlookExpress = Replace(sOutlookExpress, "\", "\\")
      nod.AddChildNode sOutlookExpress, "Outlook Express", lIcon, lIcon, True
      sCSV = sCSV & sOutlookExpress
   End If
   sDisplayName = GetSpecialFolderInfo(CSIDL_DRIVES, lIcon)
   Set nodSub = nod.AddChildNode("\\Drives", sDisplayName, lIcon, lIcon)
   LoadDrives nodSub
   nod.Expanded = True 'Expand drives
   tvMC.SpecialFolderCSV = sCSV
   bInit = True
   Exit Sub
ErrHandler:
   Debug.Print "Error " & Err.Number & vbCrLf & Err.Description
End Sub

Public Sub LoadDrives(node As cCTreeViewNode)
   Dim DrvBitMask       As Long
   Dim liIcon           As Long
   Dim lPIDL            As Long
   Dim MaxPwr           As Integer
   Dim Pwr              As Integer
   Dim MyDrive          As String
   Dim sDisplayName     As String
   Dim children         As cCTreeViewNode
   Dim subchildren      As cCTreeViewNode

   On Error GoTo ProcedureError

   DrvBitMask = GetLogicalDrives()
   ' DrvBitMask is a bitmask representing available disk drives.
   ' Bit position 0 is drive A, bit position 2 is drive C, etc.
   ' If function fails, return value is zero.
   If DrvBitMask Then
      ' Get & search each available drive
      MaxPwr = Int(Log(DrvBitMask) / Log(2)) ' a little math...
      For Pwr = 0 To MaxPwr
         If 2 ^ Pwr And DrvBitMask Then
            MyDrive = Chr$(65 + Pwr) & ":\"
            'Get Drive DisplayName(as in Explorer).
            sDisplayName = GetDisplayName(MyDrive)
            liIcon = m_SysIml.ItemIndex(MyDrive)
            node.AddChildNode MyDrive, sDisplayName, liIcon, liIcon, True
         End If
      Next
      node.Expanded = True
   End If

ProcedureExit:
   Exit Sub
ProcedureError:
   Debug.Print "Error " & Err.Number & " " & Err.Description

End Sub

Private Sub AddSpecialFolder(node As cCTreeViewNode, _
   ByVal CSIDL As Long, ByRef sCSV As String)

   Dim sDisplayName     As String
   Dim sKey             As String
   Dim lIcon            As Long
   sDisplayName = GetSpecialFolderInfo(CSIDL, lIcon)
   sKey = Replace(GetSpecialFolderPath(CSIDL), "\", "\\")
   sCSV = sCSV & sKey & ","
   node.AddChildNode sKey, sDisplayName, lIcon, lIcon, True
End Sub

Private Sub setupImageList()
   m_SysIml.IconSizeX = 16
   m_SysIml.IconSizeY = 16
   m_SysIml.Create
   'tvMC.SetSystemImagelist
   'tvMC2.SetSystemImagelist
   tvMC.ImageList = m_SysIml.hIml
   tvMC2.ImageList = m_SysIml.hIml
End Sub

Private Sub chkAutoResizeColW_Click()
   tvMC.AutoResizeColumnWidth = CBool(chkAutoResizeColW)
End Sub

Private Sub cmdGetChecked_Click()
   Dim cCol As Collection
   Set cCol = tvMC.GetCheckedFiles
   MsgBox cCol.Count, vbInformation, "Checked Files Count"
   Set cCol = Nothing
End Sub

Private Sub Form_Load()
   '
   m_CodePage = 932 'or GetUserCodePage or GetACP
   setupImageList
   setupColumns
   setupData
   
   tvMC2.Nodes.Add , , , "Server Files", m_SysIml.ItemIndex(GetWindowsDirectory)
   
   Set Splitter1.Child1 = tvMC
   Set Splitter1.Child2 = tvMC2
   Splitter1.SplitterColor = vbButtonFace
   
End Sub

Private Sub Form_Paint()
   setupImageList
End Sub

Private Sub Form_QueryUnload(cancel As Integer, UnloadMode As Integer)
   Unload Me
End Sub

Private Sub Form_Resize()
   'tvMC.Move tvMC.left, tvMC.tOp, _
      Me.ScaleWidth - tvMC.left * 2, _
      Me.ScaleHeight - tvMC.tOp - tvMC.left
   '   tvMC.Width = Me.ScaleWidth - tvMC.left * 2
   Splitter1.Move 0, 0, Me.ScaleWidth
   imgBtn(2).Left = Me.ScaleWidth - imgBtn(2).Width - 100
End Sub

Private Sub Form_Terminate()
   Set m_SysIml = Nothing
End Sub


Private Sub imgBkup_Click()
   MsgBox "Backup Now", vbInformation, "Button Click"
End Sub

Private Sub imgRestore_Click()
   MsgBox "Restore", vbInformation, "Button Click"
End Sub

Private Sub imgSchedule_Click()
   MsgBox "Schedule", vbInformation, "Button Click"
End Sub

Private Sub imgBtn_Click(Index As Integer)
   Select Case Index
       Case 0
          MsgBox "Backup Now", vbInformation, "Button Click"
       Case 1
          MsgBox "Schedule", vbInformation, "Button Click"
       Case 2
          MsgBox "Restore", vbInformation, "Button Click"
   End Select
End Sub

Private Sub mnuGetFolderSize_Click(Index As Integer)
   Dim siz              As Currency
   Dim sFolder          As String
   sFolder = Replace(tvMC.SelectedItem.Key, "\\", "\")
   If FolderExists(sFolder) Then
      Screen.MousePointer = vbHourglass
      siz = DirSizeRecursive(sFolder) * 10000
      Screen.MousePointer = vbDefault
      tvMC.SelectedItem.SubItem(1).Text = FormatSize2(siz)
      tvMC.Refresh
      MsgBox sFolder & vbCrLf & FormatSize2(siz), vbInformation, "Size of folder:"
   Else
      Debug.Print "Not a folder"
   End If
End Sub

Private Sub mnuPopup_Click()
   Dim sFolder          As String
   Dim bExists          As Boolean
   sFolder = Replace(tvMC.SelectedItem.Key, "\\", "\")
   bExists = FolderExists(sFolder)
   mnuExcludeFolder.Item(0).Enabled = bExists
   mnuExcludeFile.Item(0).Enabled = Not bExists

End Sub

Private Sub tvMC_BeforeExpand(node As prjUniTreeViewMC.cCTreeViewNode, cancel As Boolean)
   If (node.ExpandedOnce = False) And (bInit = True) Then
      Select Case node.Key
         Case "\\Drives", "\\Files" 'do nothing
         Case Else
            If chkUseShell.Value = vbUnchecked Then
               LoadItems tvMC, node, m_CodePage, , , _
                  IIf(chkSortByDate, True, False), _
                  IIf(chkSortAscending, True, False)
            Else
               LoadItemsShellNameSpace tvMC, node, , , _
                  IIf(chkSortByDate, True, False), _
                  IIf(chkSortAscending, True, False)
            End If
      End Select
   End If
   
End Sub

Private Sub tvMC_BeforeNodeCheckChange(node As prjUniTreeViewMC.cCTreeViewNode, bCancel As Boolean)
   'New: Don't let user check these 2 nodes.
   'They can be grayed programatically though.
   Select Case node.Key
      Case "\\Files", "\\Drives"
         bCancel = True
         MsgBox "Sorry. You cannot check this item.", vbInformation, "Reserved Node"
   End Select
End Sub

Private Sub tvMC_Collapse(node As prjUniTreeViewMC.cCTreeViewNode)
   'Reset col(1) to original value.
   'If AutoResizeColumnWidth = True then col(1) width will readjust itself.
   tvMC.Columns.Item(1).Width = 220
End Sub

Private Sub tvMC_NodeCheck(node As prjUniTreeViewMC.cCTreeViewNode)
   Dim sPath   As String
   Dim sMatch  As String
   sPath = node.Key
   If IsSpecialVirtual(tvMC.SpecialFolderCSV, sPath, sMatch) Then
      'Debug.Print "IsSpecialVirtual = True"; Time, sMatch
      'See if there is a coresponding disk item and check same
   ElseIf IsSpecialDisk(tvMC.SpecialFolderCSV, sPath, sMatch) Then
      'Debug.Print "IsSpecialDisk = True "; Time, sMatch
      'See if there is a coresponding special item and check same
   End If

End Sub

Private Sub tvMC_NodeRightClick(node As prjUniTreeViewMC.cCTreeViewNode)
   node.Selected = True
   PopupMenu mnuPopup
End Sub

Private Sub UniTreeViewMC1_AfterLabelEdit(node As prjUniTreeViewMC.cCTreeViewNode, NewString As String, cancel As Boolean)

End Sub


'---------

'modLoadItems
'------------
Option Explicit

' Difference between day zero for VB dates and Win32 dates
' (or #12-30-1899# - #01-01-1601#)
Private Const rDayZeroBias As Double = 109205#    ' Abs(CDbl(#01-01-1601#))
' 10000000 nanoseconds * 60 seconds * 60 minutes * 24 hours / 10000
' comes to 86400000 (the 10000 adjusts for fixed point in Currency)
Private Const rMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# / 10000#

Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Src As Any, ByVal cb As Long) As Long

Public Declare Function FindFirstFileA Lib "kernel32" (ByVal lpFilename As String, lpWIN32_FIND_DATA As WIN32_FIND_DATA_A) As Long
Public Declare Function FindNextFileA Lib "kernel32" (ByVal hFindFile As Long, lpWIN32_FIND_DATA As WIN32_FIND_DATA_A) As Long
Public Declare Function FindFirstFileW Lib "kernel32" (ByVal lpFilename As Long, lpWIN32_FIND_DATA As WIN32_FIND_DATA_W) As Long
Public Declare Function FindNextFileW Lib "kernel32" (ByVal hFindFile As Long, lpWIN32_FIND_DATA As WIN32_FIND_DATA_W) As Long
Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Public Declare Function SHGetFileInfoA Lib "shell32.dll" (ByVal pszPath As String, ByVal dwAttributes As Long, psfi As SHFILEINFOW, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long
Public Declare Function SHGetFileInfoW Lib "shell32.dll" (ByVal pszPath As Long, ByVal dwAttributes As Long, psfi As SHFILEINFOW, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (ByRef lpFileTime As Any, ByRef lpLocalFileTime As Any) As Long

'ANSI
Public Type WIN32_FIND_DATA_A
   dwFileAttributes     As Long
   ftCreationTime       As Currency
   ftLastAccessTime     As Currency
   ftLastWriteTime      As Currency
   nFileSizeBig         As Currency
   dwReserved0          As Long
   dwReserved1          As Long
   cFileName            As String * 260
   cAlternate           As String * 14
End Type

'Unicode
Public Type WIN32_FIND_DATA_W
   dwFileAttributes     As Long
   ftCreationTime       As Currency
   ftLastAccessTime     As Currency
   ftLastWriteTime      As Currency
   nFileSizeBig         As Currency
   dwReserved0          As Long
   dwReserved1          As Long
   cFileName(0 To 519)   As Byte
   cAlternate(0 To 27)   As Byte
End Type

Public Win32FdA         As WIN32_FIND_DATA_A
Public Win32FdW         As WIN32_FIND_DATA_W

Public Type SHFILEINFOA
   hIcon                As Long
   iIcon                As Long
   dwAttributes         As Long
   szDisplayName        As String * 260
   szTypeName           As String * 80
End Type

Public Type SHFILEINFOW
   hIcon                As Long
   iIcon                As Long
   dwAttributes         As Long
   szDisplayName(0 To 519) As Byte
   szTypeName(0 To 159)    As Byte
End Type

Public siA              As SHFILEINFOA
Public siW              As SHFILEINFOW

Private m_shl           As Shell

'Purpose: Load Folders/Files.
'Enumerates via FindFirstFileA or FindFirstFileW(NT or later Unicode).
'Single pass fills one array with folders, a second with files.
'Enhanced QuickSort sorts the items.

Public Sub LoadItems(tv As UniTreeViewMC, _
   node As cCTreeViewNode, _
   lCodePage As Long, _
   Optional ByVal bIncludeFiles As Boolean = True, _
   Optional ByVal bUseSysImageList As Boolean = True, _
   Optional bSortFilesByDate As Boolean = False, _
   Optional ByVal bAscending As Boolean = True)

   Dim sPath            As String
   Dim lHandle          As Long
   Dim lcount           As Long
   Dim lFolderCount     As Long
   Dim lFileCount       As Long
   Dim lIDNew           As Long
   Dim UB               As Long
   Dim sFiles()         As String
   Dim sFolders()       As String
   Dim IconIndex        As Long
   Dim SelectedIconIndex As Long
   Dim sFileName        As String
   Dim sFull            As String
   Dim nodSub           As cCTreeViewNode
   Dim FileSize         As Currency
   Dim FileDate         As Date
   Dim bIsSpecialFolder As Boolean
   Dim bChecked         As Boolean
   Dim bHasChildren     As Boolean

   Const SHGFI_ICON        As Long = &H100
   Const RedimInterval     As Long = 500

   Screen.MousePointer = vbHourglass
   tv.BeginUpdate 'Reduce flicker
           
   sPath = node.Key
   bChecked = node.Checked = etvwChecked
   bIsSpecialFolder = IsSpecialPath(sPath)
   sPath = QualifyPath(PathFromSpecial(sPath))
   ReDim sFiles(0)    'Init array
   ReDim sFolders(0)  'Init array

   If IsNT Then 'Unicode
      lHandle = FindFirstFileW(StrPtr(sPath & "*.*"), Win32FdW)
      If lHandle > 0 Then
         Do
            'If IsExplorerItemValid(Win32FdW.dwFileAttributes, bIncludeFiles) = True Then
               If (Win32FdW.dwFileAttributes And vbDirectory) = vbDirectory Then
                  sFileName = Win32FdW.cFileName ' StripNull(Win32FdW.cFileName)
                  'If sFileName <> "." And sFileName <> ".." Then
                  If Asc(sFileName) <> 46 Then
                     If (lFolderCount Mod RedimInterval) = 0 Then
                        ' Resize the array
                        ReDim Preserve sFolders(lFolderCount + RedimInterval)
                     End If
                     sFolders(lFolderCount) = sFileName
                     lFolderCount = lFolderCount + 1  ' Increment counter.
                  End If
               Else 'Must be a file
                  sFileName = Win32FdW.cFileName ' StripNull(Win32FdW.cFileName)
                  If (lFileCount Mod RedimInterval) = 0 Then
                     ' Resize the array
                     ReDim Preserve sFiles(lFileCount + RedimInterval)
                  End If
                  sFiles(lFileCount) = sFileName
                  lFileCount = lFileCount + 1  ' Increment counter.
               End If
            'End If
         Loop While FindNextFileW(lHandle, Win32FdW) > 0
      End If
   Else 'Win9x
      lHandle = FindFirstFileA(sPath & "*.*", Win32FdA)
      If lHandle > 0 Then
         Do
            'If IsExplorerItemValid(Win32FdA.dwFileAttributes, bIncludeFiles) = True Then
               If (Win32FdA.dwFileAttributes And vbDirectory) = vbDirectory Then
                  sFileName = Win32FdA.cFileName ' StripNull(Win32FdA.cFileName)
                  'If sFileName <> "." And sFileName <> ".." Then
                  If Asc(sFileName) <> 46 Then
                     If (lFolderCount Mod RedimInterval) = 0 Then
                        ' Resize the array
                        ReDim Preserve sFolders(lFolderCount + RedimInterval)
                     End If
                     sFolders(lFolderCount) = sFileName
                     lFolderCount = lFolderCount + 1  ' Increment counter.
                  End If
               Else 'Must be a file
                  sFileName = Win32FdA.cFileName ' StripNull(Win32FdA.cFileName)
                  If (lFileCount Mod RedimInterval) = 0 Then
                     ' Resize the array
                     ReDim Preserve sFiles(lFileCount + RedimInterval)
                  End If
                  sFiles(lFileCount) = sFileName
                  lFileCount = lFileCount + 1  ' Increment counter.
               End If
            'End If
         Loop While FindNextFileA(lHandle, Win32FdA) > 0
      End If
   End If

   'Transfer sorted arrays to control, folders first, then files.

   If lFolderCount Then
      ReDim Preserve sFolders(lFolderCount - 1) 'Set actual Ubound
      UB = UBound(sFolders)
      QuickSortStringsStart sFolders
      'Debug.Print "lFolderCount", lFolderCount
      For lcount = 0 To UB
         sFileName = sFolders(lcount)
         sFull = sPath & StripNull(sFileName)
         If bUseSysImageList Then
            If IsNT Then
               SHGetFileInfoW StrPtr(sFull), 0&, siW, Len(siW), SHGFI_ICON
               IconIndex = siW.iIcon
            Else
               SHGetFileInfoA sFull, 0&, siW, Len(siW), SHGFI_ICON
               IconIndex = siW.iIcon
            End If
            SelectedIconIndex = IconIndex
         End If
         GetFolderDate sFull, FileDate
         bHasChildren = HasChildren(sFull)
         sFileName = TranslateFileName(sFileName, lCodePage)
         Set nodSub = node.AddChildNode(IIf(bIsSpecialFolder, Replace(sFull, "\", "\\"), sFull), sFileName, IconIndex, SelectedIconIndex, bHasChildren)
         If bChecked Then
            nodSub.Checked = etvwChecked
         End If
         nodSub.SubItem(2).Text = FormatDateTime(FileDate, vbShortDate)
         nodSub.SubItem(3).Text = FormatDateTime(FileDate, vbShortTime)
      Next
      Erase sFolders
   End If

   If lFileCount Then
      ReDim Preserve sFiles(lFileCount - 1) 'Set actual Ubound
      UB = UBound(sFiles)
      QuickSortStringsStart sFiles, bAscending, , bSortFilesByDate, sPath
      'Debug.Print "lFileCount", lFileCount
      For lcount = 0 To UB
         sFileName = sFiles(lcount)
         sFull = sPath & StripNull(sFileName)
         If bUseSysImageList Then
            If IsNT Then
               SHGetFileInfoW StrPtr(sFull), 0&, siW, Len(siW), SHGFI_ICON
               IconIndex = siW.iIcon
            Else
               SHGetFileInfoA sFull, 0&, siW, Len(siW), SHGFI_ICON
               IconIndex = siW.iIcon
            End If
            SelectedIconIndex = IconIndex
         End If
         GetFileSize_Date sFull, FileSize, FileDate
         sFileName = TranslateFileName(sFileName, lCodePage)
         Set nodSub = node.AddChildNode(IIf(bIsSpecialFolder, Replace(sFull, "\", "\\"), sFull), sFileName, IconIndex, SelectedIconIndex)
         If bChecked Then
            nodSub.Checked = etvwChecked
         End If
         nodSub.SubItem(1).Text = FormatSize2(FileSize)
         nodSub.SubItem(2).Text = FormatDateTime(FileDate, vbShortDate)
         nodSub.SubItem(3).Text = FormatDateTime(FileDate, vbShortTime)
      Next
      Erase sFiles
   End If

   tv.EndUpdate
   Screen.MousePointer = vbDefault
           
End Sub

Public Sub LoadItemsShellNameSpace(tv As UniTreeViewMC, node As cCTreeViewNode, _
   Optional ByVal bIncludeFiles As Boolean = True, _
   Optional ByVal bUseSysImageList As Boolean = True, _
   Optional bSortFilesByDate As Boolean = False, _
   Optional ByVal bAscending As Boolean = True)
   
   Dim items            As Folder
   Dim itm              As FolderItem
   Dim sKey             As String
   Dim sPath            As String
   Dim lHandle          As Long
   Dim lcount           As Long
   Dim lFolderCount     As Long
   Dim lFileCount       As Long
   Dim lIDNew           As Long
   Dim UB               As Long
   Dim sFiles()         As String
   Dim sFolders()       As String
   Dim IconIndex        As Long
   Dim SelectedIconIndex As Long
   Dim sFileName        As String
   Dim sFull            As String
   Dim nodSub           As cCTreeViewNode
   Dim FileSize         As Currency
   Dim FileDate         As Date
   Dim bIsSpecialFolder As Boolean
   Dim bChecked         As Boolean
   Dim bHasChildren     As Boolean

   Const SHGFI_ICON        As Long = &H100
   Const RedimInterval     As Long = 500
   
On Error Resume Next

   Screen.MousePointer = vbHourglass
   tv.BeginUpdate 'Reduce flicker
   Set m_shl = New Shell

   sPath = QualifyPath(PathFromSpecial(node.Key))
   Set items = m_shl.NameSpace(sPath)
   If Not items Is Nothing Then
      For Each itm In items.items
         If (itm.IsFolder) Then
            If (lFolderCount Mod RedimInterval) = 0 Then
               ' Resize the array
               ReDim Preserve sFolders(lFolderCount + RedimInterval)
            End If
            sFolders(lFolderCount) = itm.Name
            lFolderCount = lFolderCount + 1  ' Increment counter.
         Else
            If (lFileCount Mod RedimInterval) = 0 Then
               ' Resize the array
               ReDim Preserve sFiles(lFileCount + RedimInterval)
            End If
            sFiles(lFileCount) = GetFullName(itm.Path)
            lFileCount = lFileCount + 1  ' Increment counter.
         End If
      Next
   End If

   If lFolderCount Then
      ReDim Preserve sFolders(lFolderCount - 1) 'Set actual Ubound
      UB = UBound(sFolders)
      QuickSortStringsStart sFolders
      'Debug.Print "lFolderCount", lFolderCount
      For lcount = 0 To UB
         sFileName = sFolders(lcount)
         sFull = sPath & sFileName
         If bUseSysImageList Then
            If IsNT Then
               SHGetFileInfoW StrPtr(sFull), 0&, siW, Len(siW), SHGFI_ICON
               IconIndex = siW.iIcon
            Else
               SHGetFileInfoA sFull, 0&, siW, Len(siW), SHGFI_ICON
               IconIndex = siW.iIcon
            End If
            SelectedIconIndex = IconIndex
         End If
         GetFolderDate sFull, FileDate
         bHasChildren = HasChildren(sFull)
         Set nodSub = node.AddChildNode(IIf(bIsSpecialFolder, Replace(sFull, "\", "\\"), sFull), sFileName, IconIndex, SelectedIconIndex, bHasChildren)
         If bChecked Then
            nodSub.Checked = etvwChecked
         End If
         nodSub.SubItem(2).Text = FormatDateTime(FileDate, vbShortDate)
         nodSub.SubItem(3).Text = FormatDateTime(FileDate, vbShortTime)
      Next
      Erase sFolders
   End If

   If lFileCount Then
      ReDim Preserve sFiles(lFileCount - 1) 'Set actual Ubound
      UB = UBound(sFiles)
      QuickSortStringsStart sFiles, bAscending, , bSortFilesByDate, sPath
      'Debug.Print "lFileCount", lFileCount
      For lcount = 0 To UB
         sFileName = sFiles(lcount)
         sFull = sPath & sFileName
         If bUseSysImageList Then
            If IsNT Then
               SHGetFileInfoW StrPtr(sFull), 0&, siW, Len(siW), SHGFI_ICON
               IconIndex = siW.iIcon
            Else
               SHGetFileInfoA sFull, 0&, siW, Len(siW), SHGFI_ICON
               IconIndex = siW.iIcon
            End If
            SelectedIconIndex = IconIndex
         End If
         GetFileSize_Date sFull, FileSize, FileDate
         Set nodSub = node.AddChildNode(IIf(bIsSpecialFolder, Replace(sFull, "\", "\\"), sFull), sFileName, IconIndex, SelectedIconIndex)
         If bChecked Then
            nodSub.Checked = etvwChecked
         End If
         nodSub.SubItem(1).Text = FormatSize2(FileSize)
         nodSub.SubItem(2).Text = FormatDateTime(FileDate, vbShortDate)
         nodSub.SubItem(3).Text = FormatDateTime(FileDate, vbShortTime)
      Next
      Erase sFiles
   End If

   Set m_shl = Nothing
   tv.EndUpdate
   Screen.MousePointer = vbDefault
End Sub

Private Sub GetFileSize_Date(ByVal sPath As String, _
   ByRef FileSize As Currency, ByRef FileDate As Date)
   Dim lHandle          As Long
   If IsNT Then
      lHandle = FindFirstFileW(StrPtr(sPath), Win32FdW)
      If lHandle > 0 Then
         FileSize = CVC(Win32FdW.nFileSizeBig) * 10000
         FileDate = UTCCurrToVbDate(Win32FdW.ftLastWriteTime, True)
         FindClose (lHandle)
      End If
   Else
      lHandle = FindFirstFileA(sPath, Win32FdA)
      If lHandle > 0 Then
         FileSize = CVC(Win32FdA.nFileSizeBig) * 10000
         FileDate = UTCCurrToVbDate(Win32FdA.ftLastWriteTime, True)
         FindClose (lHandle)
      End If
   End If

End Sub

Private Sub GetFolderDate(ByVal sPath As String, _
   ByRef FileDate As Date)
   Dim lHandle          As Long
   If IsNT Then
      lHandle = FindFirstFileW(StrPtr(sPath), Win32FdW)
      If lHandle > 0 Then
         FileDate = UTCCurrToVbDate(Win32FdW.ftLastWriteTime, True)
         FindClose (lHandle)
      End If
   Else
      lHandle = FindFirstFileA(sPath, Win32FdA)
      If lHandle > 0 Then
         FileDate = UTCCurrToVbDate(Win32FdA.ftLastWriteTime, True)
         FindClose (lHandle)
      End If
   End If

End Sub

'Purpose: Determine if a Folder has children, ignoring "." and ".." entries
Private Function HasChildren(ByVal sPath As String) As Boolean
   Dim lHandle          As Long
   sPath = QualifyPath(sPath) & "*.*"
   If IsNT Then
      lHandle = FindFirstFileW(StrPtr(sPath), Win32FdW)
      If lHandle > 0 Then
         Do
            If (Win32FdW.dwFileAttributes And vbDirectory) = vbDirectory Then
               If Asc(Win32FdW.cFileName) <> 46 Then
                  HasChildren = True: Exit Do
               End If
            Else 'Must be a file
               HasChildren = True: Exit Do
            End If
         Loop While FindNextFileW(lHandle, Win32FdW) > 0
         FindClose (lHandle)
      End If
   Else
      lHandle = FindFirstFileA(sPath, Win32FdA)
      If lHandle > 0 Then
         Do
            If (Win32FdA.dwFileAttributes And vbDirectory) = vbDirectory Then
               If Asc(Win32FdA.cFileName) <> 46 Then
                  HasChildren = True: Exit Do
               End If
            Else 'Must be a file
               HasChildren = True: Exit Do
            End If
         Loop While FindNextFileA(lHandle, Win32FdA) > 0
         FindClose (lHandle)
      End If
   End If

End Function

Private Function IsExplorerItemValid(ByVal lAttr As Long, _
   ByVal bIncludeFiles As Boolean) As Boolean
   
   'Allow any attribute
   IsExplorerItemValid = True
   'Exclude hidden
   'IsExplorerItemValid = (lAttr And vbHidden) = 0

   'r   0001  "Read Only"
   'h   0002  "Hidden"
   's   0004  "System"
   'v   0008  "Volume Label"
   'f   0016  "Folder"
   'a   0032  "Archive"
   'l   0064  "Alias"
   'n   0128  "Normal"
   't   0256  "Temporary"
   '?   0512   ??
   'l   1024  "Alias"
   'c   2048  "Compressed"
   'o   4096  "Offline"
   '?   8192   ??
   'e  16384  "Encrypted"
End Function

Public Function IsSpecialVirtual(ByVal sList As String, _
   ByVal sPath As String, ByRef sMatch As String) As Boolean
   
   Dim vSplit() As String
   Dim i As Long
   If Len(sList) And Len(sPath) Then
      vSplit = Split(sList, ",")
      For i = 0 To UBound(vSplit)
         If InStr(1, sPath, vSplit(i), vbTextCompare) = 1 Then
            IsSpecialVirtual = True
            sMatch = vSplit(i)
         End If
      Next
   End If
End Function

Public Function IsSpecialDisk(ByVal sList As String, _
   ByVal sPath As String, ByRef sMatch As String) As Boolean
   
   Dim vSplit() As String
   Dim i As Long
   If Len(sList) And Len(sPath) Then
      sList = PathFromSpecial(sList)
      vSplit = Split(sList, ",")
      For i = 0 To UBound(vSplit)
         If InStr(1, sPath, vSplit(i), vbTextCompare) = 1 Then
            IsSpecialDisk = True
            sMatch = vSplit(i)
         End If
      Next
   End If
End Function

Public Function IsSpecialPath(ByVal sPath As String) As Boolean
   If InStr(1, sPath, "\\", vbBinaryCompare) > 0 Then
      IsSpecialPath = True
   End If
End Function

Public Function IsPathInList(ByVal sList As String, ByVal sPath As String) As Boolean
   If InStr(1, sList, sPath, vbTextCompare) > 0 Then
      IsPathInList = True
   End If
End Function

Public Function PathFromSpecial(ByVal sPath As String) As String
   PathFromSpecial = Replace(sPath, "\\", "\")
End Function

Public Function UTCCurrToVbDate(ByVal MyCurr As Currency, Optional ToLocal As Boolean = True) As Date
   Dim UTC              As Currency
   ' Discrepancy in WIN32_FIND_DATA:
   ' Win2000 correctly reports 0 as 01-01-1980, Win98/ME does not.
   If MyCurr = 0 Then MyCurr = 11960017200000# ' 01-01-1980
   If ToLocal Then
      FileTimeToLocalFileTime MyCurr, UTC
   Else
      UTC = MyCurr
   End If
   UTCCurrToVbDate = (UTC / rMillisecondPerDay) - rDayZeroBias
End Function

'Purpose: Recurse from sPath and return Total of FileSizes
Public Function DirSizeRecursive(sPath As String) As Currency
   Dim lHandle          As Long
   Dim sFileName        As String

   sPath = QualifyPath(sPath)
   If IsNT Then
      lHandle = FindFirstFileW(StrPtr(sPath & "*.*"), Win32FdW)
      If lHandle > 0 Then
         Do
            If Asc(Win32FdW.cFileName) <> 46 Then  'skip . and .. entries
               If (Win32FdW.dwFileAttributes And vbDirectory) = 0 Then
                  'OLD DirSizeRecursive = DirSizeRecursive + Win32Fd.nFileSizeLow
                  DirSizeRecursive = DirSizeRecursive + CVC(Win32FdW.nFileSizeBig)
               Else 'Recurse
                  sFileName = StripNull(Win32FdW.cFileName)
                  DirSizeRecursive = DirSizeRecursive + DirSizeRecursive(sPath & sFileName)
               End If
            End If
         Loop While FindNextFileW(lHandle, Win32FdW) > 0
      End If
      FindClose (lHandle)
   Else
      lHandle = FindFirstFileA(sPath & "*.*", Win32FdA)
      If lHandle > 0 Then
         Do
            If Asc(Win32FdA.cFileName) <> 46 Then 'skip . and .. entries
               If (Win32FdA.dwFileAttributes And vbDirectory) = 0 Then
                  'OLD DirSizeRecursive = DirSizeRecursive + Win32Fd.nFileSizeLow
                  DirSizeRecursive = DirSizeRecursive + CVC(Win32FdA.nFileSizeBig)
               Else 'Recurse
                  sFileName = StripNull(Win32FdA.cFileName)
                  DirSizeRecursive = DirSizeRecursive + DirSizeRecursive(sPath & sFileName)
               End If
            End If
         Loop While FindNextFileA(lHandle, Win32FdA) > 0
      End If
      FindClose (lHandle)
   End If

End Function

Public Function FolderExists(ByVal sPath As String) As Boolean
   Dim objFSO           As Object
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   FolderExists = objFSO.FolderExists(sPath)
   Set objFSO = Nothing
End Function

Public Function GetExtDot(ByVal Name As String) As String
   Dim j                As Integer
   j = InStrRev(Name, ".")
   If j > 0 And j < Len(Name) Then
      GetExtDot = Mid$(Name, j)
   End If
End Function

Public Function GetFullName(ByVal Name As String) As String
   Dim j                As Integer
   j = InStrRev(Name, "\")
   If j > 0 And j < Len(Name) Then
      GetFullName = Mid$(Name, j + 1)
   End If
End Function


'------------


'modGetFileInfo
'--------------
Option Explicit

Private Const MAX_PATH  As Long = 260
Private Const SHGFI_ICON As Long = &H100
Private Const SHGFI_DISPLAYNAME As Long = &H200
Private Const SHGFI_TYPENAME As Long = &H400
Private Const SHGFI_PIDL As Long = &H8

Private Declare Function SHGetFileInfoA Lib "shell32.dll" (ByVal pszPath As String, ByVal dwAttributes As Long, psfi As SHFILEINFOU, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function SHGetFileInfoW Lib "shell32.dll" (ByVal pszPath As Long, ByVal dwAttributes As Long, psfi As SHFILEINFOU, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long

Private Type SHFILEINFOU
   hIcon                As Long
   iIcon                As Long
   dwAttributes         As Long
   szDisplayName(0 To 519) As Byte
   szTypeName(0 To 159)    As Byte
End Type

Public Function GetDisplayName(ByVal sName As String) As String
   Dim si               As SHFILEINFOU

   If IsNT Then
      Call SHGetFileInfoW(StrPtr(sName), 0, si, Len(si), SHGFI_DISPLAYNAME)
      GetDisplayName = StripNull(si.szDisplayName)
   Else
      Call SHGetFileInfoA(sName, 0, si, Len(si), SHGFI_DISPLAYNAME)
      GetDisplayName = StripNull(si.szDisplayName)
   End If

End Function

Public Function GetIconIndex(ByVal sName As String) As String
   Dim si               As SHFILEINFOU

   If IsNT Then
      Call SHGetFileInfoW(StrPtr(sName), 0, si, Len(si), SHGFI_ICON)
      GetIconIndex = si.iIcon
   Else
      Call SHGetFileInfoA(sName, 0, si, Len(si), SHGFI_ICON)
      GetIconIndex = si.iIcon
   End If

End Function

'--------------

'modUniResource
'--------------

Option Explicit

'---- Rip resource strings from Windows Dll's ----
'---- Valid for all versions of Windows
'   sFolder = GetResourceStringFromFile(4131) '"(" & GetResourceStringFromFile(4131) & ")"
'   sFile = GetResourceStringFromFile(4130)
'   sName = GetResourceStringFromFile(8976)
'   sExtension = StrConv(ext_, vbProperCase)
'   sSize = GetResourceStringFromFile(8978)
'   sType = GetResourceStringFromFile(8979)
'   sModified = GetResourceStringFromFile(8980)
'   sTime = GetResourceStringFromFile(25,"Intl.Cpl")
'   sCreated = GetResourceStringFromFile(8996)
'   sAccessed = GetResourceStringFromFile(8997)
'   sAttribute = GetResourceStringFromFile(8987)
'   sMsDos = "MsDos 8.3"
'   sNone = GetResourceStringFromFile(9808)

Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As Long) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Private Declare Function LoadLibraryW Lib "kernel32" (ByVal lpLibFileName As Long) As Long
Private Declare Function LoadStringA Lib "User32" (ByVal hInstance As Long, ByVal uId As Long, ByVal lpBuffer As String, ByVal nBufferMax As Long) As Long
Private Declare Function LoadStringW Lib "User32" (ByVal hInstance As Long, ByVal uId As Long, ByVal lpBuffer As String, ByVal nBufferMax As Long) As Long
Private Const MAX_PATH = 260
Private Buffer          As String * MAX_PATH

Public Function GetResourceStringFromFile(ByVal idString As Long, _
   Optional sModule As String = "Shell32.Dll") As String

   Dim hModule          As Long
   Dim nChars           As Long
   Dim FreeLib          As Boolean

   ' is module already mapped into this process?
   hModule = GetModuleHandle(sModule)
   If hModule = 0 Then ' load module
      hModule = LoadLibrary(sModule)
      FreeLib = True
   End If

   If hModule Then ' get resource idString.
      GetResourceStringFromFile = LoadString(hModule, idString)
   End If

   ' unload library if we loaded it here.
   If FreeLib Then Call FreeLibrary(hModule)

End Function

Private Function LoadString(ByVal hModule As Long, ByVal idString As Long) As String
   Dim nChars           As Long

   If hModule Then
      If IsNT Then
         nChars = LoadStringW(hModule, idString, Buffer, MAX_PATH)
         If nChars Then
            LoadString = Left$(StrConv(Buffer, vbFromUnicode), nChars)
         End If
      Else
         nChars = LoadStringA(hModule, idString, Buffer, MAX_PATH)
         If nChars Then
            LoadString = Left$(Buffer, nChars)
         End If
      End If
      FreeLibrary hModule
   End If
End Function

Private Function GetModuleHandle(ByVal sModule As String) As Long
   If IsNT Then
      GetModuleHandle = GetModuleHandleW(StrPtr(sModule))
   Else
      GetModuleHandle = GetModuleHandleA(sModule)
   End If
End Function

Private Function LoadLibrary(ByVal sModule As String) As Long
   If IsNT Then
      LoadLibrary = LoadLibraryW(StrPtr(sModule))
   Else
      LoadLibrary = LoadLibraryA(sModule)
   End If
End Function
'-----------------


'cVBALSysImageList
'-----------------
Option Explicit

'Modified CyberActiveX.com to handle Unicode

' =========================================================================
' vbAccelerator Image List Control Demonstrator
' Copyright © 1998 Steve McMahon (steve@dogma.demon.co.uk)
'
' Implements an Image List control in VB using COMCTL32.DLL
'
' Visit vbAccelerator at www.dogma.demon.co.uk
' =========================================================================
'Undocumented SysImageList stuff
Private Declare Function FileIconInit Lib "shell32.dll" Alias "#660" (ByVal bFullInit As Boolean) As Boolean
Private Declare Function Shell_GetCachedImageIndex Lib "shell32.dll" Alias "#72" (ByVal lPath As Long, lIndex As Long) As Long
Private Declare Function Shell_GetImageLists Lib "shell32.dll" Alias "#71" (lHimlLarge As Long, lHimlSmall As Long) As Long

' -----------
' API
' -----------
' General:
Private Declare Function GetWindowWord Lib "User32" (ByVal hwnd As Long, ByVal nIndex As Long) As Integer
Private Const GWW_HINSTANCE = (-6)

' GDI object functions:
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DestroyCursor Lib "User32" (ByVal hCursor As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetDC Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "User32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Const BITSPIXEL = 12
Private Const LOGPIXELSX = 88    '  Logical pixels/inch in X
Private Const LOGPIXELSY = 90    '  Logical pixels/inch in Y
' System metrics:
Private Declare Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
Private Const SM_CXICON = 11
Private Const SM_CYICON = 12
Private Const SM_CXFRAME = 32
Private Const SM_CYCAPTION = 4
Private Const SM_CYFRAME = 33
Private Const SM_CYBORDER = 6
Private Const SM_CXBORDER = 5

' Region paint and fill functions:
Private Declare Function PaintRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
Private Const FLOODFILLBORDER = 0
Private Const FLOODFILLSURFACE = 1
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

' Pen functions:
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_DASH = 1
Private Const PS_DASHDOT = 3
Private Const PS_DASHDOTDOT = 4
Private Const PS_DOT = 2
Private Const PS_SOLID = 0
Private Const PS_NULL = 5

' Brush functions:
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long

' Line functions:
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Type POINTAPI
   X                    As Long
   Y                    As Long
End Type
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long

' Colour functions:
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Const OPAQUE = 2
Private Const TRANSPARENT = 1
Private Declare Function GetSysColor Lib "User32" (ByVal nIndex As Long) As Long
Private Const COLOR_ACTIVEBORDER = 10
Private Const COLOR_ACTIVECAPTION = 2
Private Const COLOR_ADJ_MAX = 100
Private Const COLOR_ADJ_MIN = -100
Private Const COLOR_APPWORKSPACE = 12
Private Const COLOR_BACKGROUND = 1
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNHIGHLIGHT = 20
Private Const COLOR_BTNSHADOW = 16
Private Const COLOR_BTNTEXT = 18
Private Const COLOR_CAPTIONTEXT = 9
Private Const COLOR_GRAYTEXT = 17
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14
Private Const COLOR_INACTIVEBORDER = 11
Private Const COLOR_INACTIVECAPTION = 3
Private Const COLOR_INACTIVECAPTIONTEXT = 19
Private Const COLOR_MENU = 4
Private Const COLOR_MENUTEXT = 7
Private Const COLOR_SCROLLBAR = 0
Private Const COLOR_WINDOW = 5
Private Const COLOR_WINDOWFRAME = 6
Private Const COLOR_WINDOWTEXT = 8
Private Const COLORONCOLOR = 3

' Shell Extract icon functions:
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

' Icon functions:
Private Declare Function DrawIcon Lib "User32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Private Declare Function DestroyIcon Lib "User32" (ByVal hIcon As Long) As Long
Private Declare Function DrawIconEx Lib "User32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Boolean
Private Declare Function LoadImage Lib "User32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function LoadImageLong Lib "User32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Const LR_LOADMAP3DCOLORS = &H1000
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADTRANSPARENT = &H20
Private Const LR_COPYRETURNORG = &H4

' Blitting functions
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCAND = &H8800C6
Private Const SRCCOPY = &HCC0020
Private Const SRCERASE = &H440328
Private Const SRCINVERT = &H660046
Private Const SRCPAINT = &HEE0086
Private Const BLACKNESS = &H42
Private Const WHITENESS = &HFF0062
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function LoadBitmapBynum Lib "User32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As Long) As Long
Private Type BITMAP '14 bytes
   bmType               As Long
   bmWidth              As Long
   bmHeight             As Long
   bmWidthBytes         As Long
   bmPlanes             As Integer
   bmBitsPixel          As Integer
   bmBits               As Long
End Type
Private Declare Function CreateBitmapIndirect Lib "gdi32" (lpBitmap As BITMAP) As Long

' Text functions:
Private Type RECT
   Left                 As Long
   Top                  As Long
   Right                As Long
   Bottom               As Long
End Type
Private Declare Function PtInRect Lib "User32" (lpRect As RECT, ByVal ptX As Long, ByVal ptY As Long) As Long
Private Declare Function DrawText Lib "User32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_BOTTOM = &H8&
Private Const DT_CENTER = &H1&
Private Const DT_LEFT = &H0&
Private Const DT_CALCRECT = &H400&
Private Const DT_WORDBREAK = &H10&
Private Const DT_VCENTER = &H4&
Private Const DT_TOP = &H0&
Private Const DT_TABSTOP = &H80&
Private Const DT_SINGLELINE = &H20&
Private Const DT_RIGHT = &H2&
Private Const DT_NOCLIP = &H100&
Private Const DT_INTERNAL = &H1000&
Private Const DT_EXTERNALLEADING = &H200&
Private Const DT_EXPANDTABS = &H40&
Private Const DT_CHARSTREAM = 4&
Private Const DT_NOPREFIX = &H800&
Private Type DRAWTEXTPARAMS
   cbSize               As Long
   iTabLength           As Long
   iLeftMargin          As Long
   iRightMargin         As Long
   uiLengthDrawn        As Long
End Type
Private Declare Function DrawTextEx Lib "User32" Alias "DrawTextExA" (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, lpDrawTextParams As DRAWTEXTPARAMS) As Long
Private Declare Function DrawTextExAsNull Lib "User32" Alias "DrawTextExA" (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDrawTextParams As Long) As Long
Private Const DT_EDITCONTROL = &H2000&
Private Const DT_PATH_ELLIPSIS = &H4000&
Private Const DT_END_ELLIPSIS = &H8000&
Private Const DT_MODIFYSTRING = &H10000
Private Const DT_RTLREADING = &H20000
Private Const DT_WORD_ELLIPSIS = &H40000

Private Type SIZEAPI
   cX                   As Long
   cY                   As Long
End Type
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZEAPI) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Const ANSI_FIXED_FONT = 11
Private Const ANSI_VAR_FONT = 12
Private Const SYSTEM_FONT = 13
Private Const DEFAULT_GUI_FONT = 17 'win95 only
Private Declare Function FillRect Lib "User32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function DrawEdge Lib "User32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Const BF_LEFT = 1
Private Const BF_TOP = 2
Private Const BF_RIGHT = 4
Private Const BF_BOTTOM = 8
Private Const BF_RECT = BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM
Private Const BF_MIDDLE = 2048
Private Const BDR_SUNKENINNER = 8
Private Const BDR_SUNKENOUTER = 2
Private Const BDR_RAISEDOUTER = 1
Private Const BDR_RAISEDINNER = 4

Private Declare Function ShowWindow Lib "User32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const SW_SHOWNOACTIVATE = 4

' Scrolling and region functions:
Private Declare Function ScrollDC Lib "User32" (ByVal hdc As Long, ByVal dx As Long, ByVal dy As Long, lprcScroll As RECT, lprcClip As RECT, ByVal hrgnUpdate As Long, lprcUpdate As RECT) As Long
Private Declare Function SetWindowRgn Lib "User32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" (lpPoint As POINTAPI, lpPolyCounts As Long, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long)
Private Declare Function SaveDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function RestoreDC Lib "gdi32" (ByVal hdc As Long, ByVal hSavedDC As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long

Private Const LF_FACESIZE = 32
Private Type LOGFONT
   lfHeight             As Long
   lfWidth              As Long
   lfEscapement         As Long
   lfOrientation        As Long
   lfWeight             As Long
   lfItalic             As Byte
   lfUnderline          As Byte
   lfStrikeOut          As Byte
   lfCharSet            As Byte
   lfOutPrecision       As Byte
   lfClipPrecision      As Byte
   lfQuality            As Byte
   lfPitchAndFamily     As Byte
   lfFaceName(LF_FACESIZE) As Byte
End Type
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function DrawFocusRect Lib "User32" (ByVal hdc As Long, lpRect As RECT) As Long

Private Declare Function DrawState Lib "User32" Alias "DrawStateA" _
   (ByVal hdc As Long, _
   ByVal hBrush As Long, _
   ByVal lpDrawStateProc As Long, _
   ByVal lParam As Long, _
   ByVal wParam As Long, _
   ByVal X As Long, _
   ByVal Y As Long, _
   ByVal cX As Long, _
   ByVal cY As Long, _
   ByVal fuFlags As Long) As Long

'/* Image type */
Private Const DST_COMPLEX = &H0&
Private Const DST_TEXT = &H1&
Private Const DST_PREFIXTEXT = &H2&
Private Const DST_ICON = &H3&
Private Const DST_BITMAP = &H4&

' /* State type */
Private Const DSS_NORMAL = &H0&
Private Const DSS_UNION = &H10& ' Dither
Private Const DSS_DISABLED = &H20&
Private Const DSS_MONO = &H80& ' Draw in colour of brush specified in hBrush
Private Const DSS_RIGHT = &H8000&

Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1

' Shell Functions for SystemImageList
Private Const MAX_PATH = 260
Private Type SHFILEINFOA
   hIcon                As Long
   iIcon                As Long
   dwAttributes         As Long
   szDisplayName        As String * MAX_PATH
   szTypeName           As String * 80
End Type
'Use this for both Unicode and ANSI
Private Type SHFILEINFOW
   hIcon                As Long
   iIcon                As Long
   dwAttributes         As Long
   szDisplayName(0 To 519) As Byte
   szTypeName(0 To 159) As Byte
End Type

Private siA             As SHFILEINFOA
Private siW             As SHFILEINFOW

Private Declare Function SHGetFileInfoA Lib "shell32.dll" (ByVal pszPath As String, ByVal dwAttributes As Long, psfi As SHFILEINFOA, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function SHGetFileInfoW Lib "shell32.dll" (ByVal pszPath As Long, ByVal dwAttributes As Long, psfi As SHFILEINFOW, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long
Private Enum EShellGetFileInfoConstants
   SHGFI_ICON = &H100                       ' // get icon
   SHGFI_DISPLAYNAME = &H200                ' // get display name
   SHGFI_TYPENAME = &H400                   ' // get type name
   SHGFI_ATTRIBUTES = &H800                 ' // get attributes
   SHGFI_ICONLOCATION = &H1000              ' // get icon location
   SHGFI_EXETYPE = &H2000                   ' // return exe type
   SHGFI_SYSICONINDEX = &H4000              ' // get system icon index
   SHGFI_LINKOVERLAY = &H8000               ' // put a link overlay on icon
   SHGFI_SELECTED = &H10000                 ' // show icon in selected state
   SHGFI_ATTR_SPECIFIED = &H20000           ' // get only specified attributes
   SHGFI_LARGEICON = &H0                    ' // get large icon
   SHGFI_SMALLICON = &H1                    ' // get small icon
   SHGFI_OPENICON = &H2                     ' // get open icon
   SHGFI_SHELLICONSIZE = &H4                ' // get shell size icon
   SHGFI_PIDL = &H8                         ' // pszPath is a pidl
   SHGFI_USEFILEATTRIBUTES = &H10           ' // use passed dwFileAttribute
End Enum
Private Const FILE_ATTRIBUTE_NORMAL = &H80

' Image list functions:
Private Declare Function ImageList_GetBkColor Lib "COMCTL32" (ByVal hImageList As Long) As Long
Private Declare Function ImageList_ReplaceIcon Lib "COMCTL32" (ByVal hImageList As Long, ByVal i As Long, ByVal hIcon As Long) As Long
Private Declare Function ImageList_Convert Lib "COMCTL32" Alias "ImageList_Draw" (ByVal hImageList As Long, ByVal ImgIndex As Long, ByVal hDCDest As Long, ByVal X As Long, ByVal Y As Long, ByVal flags As Long) As Long
Private Declare Function ImageList_Create Lib "COMCTL32" (ByVal MinCx As Long, ByVal MinCy As Long, ByVal flags As Long, ByVal cInitial As Long, ByVal cGrow As Long) As Long
Private Declare Function ImageList_AddMasked Lib "COMCTL32" (ByVal hImageList As Long, ByVal hbmImage As Long, ByVal crMask As Long) As Long
Private Declare Function ImageList_Replace Lib "COMCTL32" (ByVal hImageList As Long, ByVal ImgIndex As Long, ByVal hbmImage As Long, ByVal hBmMask As Long) As Long
Private Declare Function ImageList_Add Lib "COMCTL32" (ByVal hImageList As Long, ByVal hbmImage As Long, hBmMask As Long) As Long
Private Declare Function ImageList_Remove Lib "COMCTL32" (ByVal hImageList As Long, ByVal ImgIndex As Long) As Long
Private Type IMAGEINFO
   hBitmapImage         As Long
   hBitmapMask          As Long
   cPlanes              As Long
   cBitsPerPixel        As Long
   rcImage              As RECT
End Type
Private Declare Function ImageList_GetImageInfo Lib "comctl32.dll" ( _
   ByVal hIml As Long, _
   ByVal i As Long, _
   pImageInfo As IMAGEINFO _
   ) As Long
Private Declare Function ImageList_AddIcon Lib "COMCTL32" (ByVal hIml As Long, ByVal hIcon As Long) As Long
Private Declare Function ImageList_GetIcon Lib "COMCTL32" (ByVal hImageList As Long, ByVal ImgIndex As Long, ByVal fuFlags As Long) As Long
Private Declare Function ImageList_SetImageCount Lib "COMCTL32" (ByVal hImageList As Long, uNewCount As Long)
Private Declare Function ImageList_GetImageCount Lib "COMCTL32" (ByVal hImageList As Long) As Long
Private Declare Function ImageList_Destroy Lib "COMCTL32" (ByVal hImageList As Long) As Long
Private Declare Function ImageList_GetIconSize Lib "COMCTL32" (ByVal hImageList As Long, cX As Long, cY As Long) As Long
Private Declare Function ImageList_SetIconSize Lib "COMCTL32" (ByVal hImageList As Long, cX As Long, cY As Long) As Long

' ImageList functions:
' Draw:
Private Declare Function ImageList_Draw Lib "comctl32.dll" ( _
   ByVal hIml As Long, _
   ByVal i As Long, _
   ByVal hdcDst As Long, _
   ByVal X As Long, _
   ByVal Y As Long, _
   ByVal fStyle As Long _
   ) As Long
Private Const ILD_NORMAL = 0&
Private Const ILD_TRANSPARENT = 1&
Private Const ILD_BLEND25 = 2&
Private Const ILD_SELECTED = 4&
Private Const ILD_FOCUS = 4&
Private Const ILD_MASK = &H10&
Private Const ILD_IMAGE = &H20&
Private Const ILD_ROP = &H40&
Private Const ILD_OVERLAYMASK = 3840&
Private Declare Function ImageList_GetImageRect Lib "comctl32.dll" ( _
   ByVal hIml As Long, _
   ByVal i As Long, _
   prcImage As RECT _
   ) As Long
' Messages:
Private Declare Function ImageList_DrawEx Lib "COMCTL32" (ByVal hIml As Long, ByVal i As Long, ByVal hdcDst As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal rgbBk As Long, ByVal rgbFg As Long, ByVal fStyle As Long) As Long
Private Declare Function ImageList_LoadImage Lib "COMCTL32" Alias "ImageList_LoadImageA" (ByVal hInst As Long, ByVal lpbmp As String, ByVal cX As Long, ByVal cGrow As Long, ByVal crMask As Long, ByVal uType As Long, ByVal uFlags As Long)
Private Declare Function ImageList_SetBkColor Lib "COMCTL32" (ByVal hImageList As Long, ByVal clrBk As Long) As Long

Private Const ILC_MASK = &H1&

Private Const CLR_DEFAULT = -16777216
Private Const CLR_HILIGHT = -16777216
Private Const CLR_NONE = -1

Private Const ILCF_MOVE = &H0&
Private Const ILCF_SWAP = &H1&
Private Declare Function ImageList_Copy Lib "COMCTL32" (ByVal himlDst As Long, ByVal iDst As Long, ByVal himlSrc As Long, ByVal iSrc As Long, ByVal uFlags As Long) As Long

Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Private Type PictDesc
   cbSizeofStruct       As Long
   picType              As Long
   hImage               As Long
   xExt                 As Long
   yExt                 As Long
End Type
Private Type Guid
   Data1                As Long
   Data2                As Integer
   Data3                As Integer
   Data4(0 To 7) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long

' -----------
' ENUMS
' -----------

'Public Enum esilColourDepth
'    ILC_COLOR = &H0
'    ILC_COLOR4 = &H4
'    ILC_COLOR8 = &H8
'    ILC_COLOR16 = &H10
'    ILC_COLOR24 = &H18
'    ILC_COLOR32 = &H20
'End Enum
' ------------------
' Private variables:
' ------------------
Private m_hIml          As Long
Private m_lIconSizeX    As Long
Private m_lIconSizeY    As Long

'Public Property Get SystemColourDepth() As esilColourDepth
'Dim lR As Long
'Dim lHDC As Long
'   lHDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
'   lR = GetDeviceCaps(lHDC, BITSPIXEL)
'   DeleteDC lHDC
'   SystemColourDepth = lR
'End Property
Private Function Create2000() As Boolean
   Dim lHimlLarge As Long
   Dim lHimlSmall As Long
   FileIconInit True
   Shell_GetImageLists lHimlLarge, lHimlSmall
   If IconSizeX < 32 Then
      m_hIml = lHimlSmall
   Else
      m_hIml = lHimlLarge
   End If
   Create2000 = m_hIml > 0
   
End Function
Public Function Create() As Boolean
   Dim dwFlags          As Long
   Dim hIml             As Long

   ' Do we already have an image list?  Kill it if we have:
   Destroy

   If Is2000OrAbove Then
      Create = Create2000
      Exit Function
   End If

   dwFlags = SHGFI_SYSICONINDEX 'SHGFI_USEFILEATTRIBUTES Or SHGFI_SYSICONINDEX
   If IconSizeX < 32 Then
      dwFlags = dwFlags Or SHGFI_SMALLICON
   End If

   '// Load the image list - use an arbitrary file extension for the
   '// call to SHGetFileInfo (we don't want to touch the disk, so use
   '// FILE_ATTRIBUTE_NORMAL && SHGFI_USEFILEATTRIBUTES).
   hIml = SHGetFileInfoA(Left(CurDir, 3), 0, siA, LenB(siA), dwFlags)

   'Create the Imagelist:
   If (hIml <> 0) And (hIml <> -1) Then
      ' Ok
      m_hIml = hIml
      Create = True
   Else
      m_hIml = 0
   End If

End Function

Public Sub Destroy()
   ' No need to do anything other than clear our
   ' handle:
   m_hIml = 0
End Sub

Public Sub DrawImage( _
   ByVal vKey As Variant, _
   ByVal hdc As Long, _
   ByVal xPixels As Integer, _
   ByVal yPixels As Integer, _
   Optional ByVal bSelected = False, _
   Optional ByVal bCut = False, _
   Optional ByVal bDisabled = False, _
   Optional ByVal oCutDitherColour As OLE_COLOR = vbWindowBackground, _
   Optional ByVal hExternalIml As Long = 0 _
   )
   Dim hIcon            As Long
   Dim lFlags           As Long
   Dim lhIml            As Long
   Dim lColor           As Long
   Dim iImgIndex        As Long

   ' Draw the image at 1 based index or key supplied in vKey.
   ' on the hDC at xPixels,yPixels with the supplied options.
   ' You can even draw an ImageList from another ImageList control
   ' if you supply the handle to hExternalIml with this function.

   iImgIndex = ItemIndex(vKey)
   If (iImgIndex > -1) Then
      If (hExternalIml <> 0) Then
         lhIml = hExternalIml
      Else
         lhIml = hIml
      End If

      lFlags = ILD_TRANSPARENT
      If (bSelected) Or (bCut) Then
         lFlags = lFlags Or ILD_SELECTED
      End If

      If (bCut) Then
         ' Draw dithered:
         lColor = TranslateColor(oCutDitherColour)
         If (lColor = -1) Then lColor = GetSysColor(COLOR_WINDOW)
         ImageList_DrawEx _
            lhIml, _
            iImgIndex, _
            hdc, _
            xPixels, yPixels, 0, 0, _
            CLR_NONE, lColor, _
            lFlags
      ElseIf (bDisabled) Then
         ' extract a copy of the icon:
         hIcon = ImageList_GetIcon(hIml, iImgIndex, 0)
         ' Draw it disabled at x,y:
         DrawState hdc, 0, 0, hIcon, 0, xPixels, yPixels, m_lIconSizeX, m_lIconSizeY, DST_ICON Or DSS_DISABLED
         ' Clear up the icon:
         DestroyIcon hIcon

      Else
         ' Standard draw:
         ImageList_Draw _
            lhIml, _
            iImgIndex, _
            hdc, _
            xPixels, _
            yPixels, _
            lFlags
      End If
   End If
End Sub

Public Property Get IconSizeX() As Long
   ' Returns the icon width
   IconSizeX = m_lIconSizeX
End Property

Public Property Let IconSizeX(ByVal lSizeX As Long)
   ' Sets the icon width.  NB no change at runtime unless you
   ' call Create and add all the images in again.
   m_lIconSizeX = lSizeX
End Property

Public Property Get IconSizeY() As Long
   ' Returns the icon height:
   IconSizeY = m_lIconSizeY
End Property

Public Property Let IconSizeY(ByVal lSizeY As Long)
   ' Sets the icon height.  NB no change at runtime unless you
   ' call Create and add all the images in again.
   m_lIconSizeY = lSizeY
End Property

Public Property Get ItemIndex( _
   ByVal vKey As Variant, _
   Optional ByVal bForceLoadFromDisk As Boolean = False _
   ) As Long
   Dim lR               As Long
   Dim i                As Long
   Dim dwFlags          As Long
   Dim dwAttributes     As Long
   Dim sKey             As String

   'If Is2000OrAbove Then
   '   If (IsNumeric(vKey)) Then
   '      ItemIndex = vKey
   '   Else
   '      sKey = CStr(vKey) 'NEW undocumented handler
   '      lR = Shell_GetCachedImageIndex(StrPtr(sKey), i)
   '      ItemIndex = i
   '   End If
   '   Exit Property
   'End If

   ' Returns the 0 based Index for the selected
   ' Image list item:
   If (IsNumeric(vKey)) Then
      ItemIndex = vKey
   Else

      'dwFlags = SHGFI_SYSICONINDEX
      'If IconSizeX >= 32 Then
      '   dwFlags = dwFlags Or SHGFI_LARGEICON
      'Else
      '   dwFlags = dwFlags Or SHGFI_SMALLICON
      'End If

      ' We choose whether to access the disk or not. If you don't
      ' hit the disk, you may get the wrong icon if the icon is
      ' not cached. But the speed is very good!
      'If Not bForceLoadFromDisk Then
      '   dwFlags = dwFlags Or SHGFI_USEFILEATTRIBUTES
      'End If

      ' sFileSpec can be any file. You can specify a
      ' file that does not exist and still get the
      ' icon, for example sFileSpec = "C:\PANTS.DOC"
      sKey = CStr(vKey)
      If IsNT Then
         'dwAttributes=0
         siW.iIcon = -1
         lR = SHGetFileInfoW(StrPtr(sKey), FILE_ATTRIBUTE_NORMAL, siW, LenB(siW), SHGFI_SMALLICON Or SHGFI_ICON)
         ItemIndex = siW.iIcon
      Else
         siA.iIcon = -1
         lR = SHGetFileInfoA(sKey, FILE_ATTRIBUTE_NORMAL, siA, LenB(siA), SHGFI_SMALLICON Or SHGFI_ICON)
         ItemIndex = siA.iIcon
      End If

   End If

End Property

Public Property Get ItemOpenIndex( _
   ByVal vKey As Variant, _
   Optional ByVal bForceLoadFromDisk As Boolean = False _
   ) As Long
   Dim lR               As Long
   Dim i                As Long
   Dim dwFlags          As Long

   ' Returns the 0 based Index for the selected
   ' Image list item:
   If (IsNumeric(vKey)) Then
      ItemOpenIndex = vKey
   Else

      'dwFlags = SHGFI_SYSICONINDEX Or SHGFI_OPENICON
      'If IconSizeX >= 32 Then
      '   dwFlags = dwFlags Or SHGFI_LARGEICON
      'Else
      '   dwFlags = dwFlags Or SHGFI_SMALLICON
      'End If

      ' We choose whether to access the disk or not. If you don't
      ' hit the disk, you may get the wrong icon if the icon is
      ' not cached. But the speed is very good!
      If Not bForceLoadFromDisk Then
         dwFlags = dwFlags Or SHGFI_USEFILEATTRIBUTES
      End If

      ' sFileSpec can be any file. You can specify a
      ' file that does not exist and still get the
      ' icon, for example sFileSpec = "C:\PANTS.DOC"
      If IsNT Then
         lR = SHGetFileInfoW(StrPtr(vKey), FILE_ATTRIBUTE_NORMAL, siW, LenB(siW), SHGFI_ICON + SHGFI_OPENICON)
         ItemOpenIndex = siW.iIcon
      Else
         lR = SHGetFileInfoA(vKey, FILE_ATTRIBUTE_NORMAL, siA, LenB(siA), SHGFI_ICON + SHGFI_OPENICON)
         ItemOpenIndex = siA.iIcon
      End If

   End If

End Property

Public Property Get ItemPicture(ByVal vKey As Variant) As IPicture
   Dim lIndex           As Long
   Dim hIcon            As Long
   ' Returns a StdPicture for an image in the ImageList:
   lIndex = ItemIndex(vKey)
   If (lIndex > -1) Then
      hIcon = ImageList_GetIcon(m_hIml, lIndex, ILD_TRANSPARENT)
      If (hIcon <> 0) Then
         Set ItemPicture = IconToPicture(hIcon)
         ' Don't destroy the icon - it is now owned by
         ' the picture object
      End If
   End If

End Property

Public Property Get ItemCopyOfIcon(ByVal vKey As Variant) As Long
   Dim lIndex           As Long
   ' Returns a hIcon for an image in the ImageList.  User must
   ' call DestroyIcon on the returned handle.
   lIndex = ItemIndex(vKey)
   If (lIndex > -1) Then
      ItemCopyOfIcon = ImageList_GetIcon(m_hIml, lIndex, ILD_TRANSPARENT)
   End If
End Property

Public Sub Clear()
   ' Recreates the image list.
   Create
End Sub

Public Property Get hIml() As Long
   ' Returns the ImageList handle:
   hIml = m_hIml
End Property

Public Function ImagePictureStrip( _
   vKeys() As Variant, _
   Optional ByVal oBackColor As OLE_COLOR = vbButtonFace, _
   Optional ByVal bForceLoadFromDisk As Boolean = False _
   ) As IPicture
   Dim iStart           As Long
   Dim iEnd             As Long
   Dim iImgIndex        As Long
   Dim lHDC             As Long
   Dim lcHDC            As Long
   Dim lParenthDC       As Long
   Dim lhBmp            As Long
   Dim lhBmpOld         As Long
   Dim lSizeX           As Long
   Dim hBr              As Long
   Dim tR               As RECT
   Dim lColor           As Long

   If (m_hIml <> 0) Then

      On Error Resume Next
      iStart = LBound(vKeys)
      iEnd = UBound(vKeys)

      On Error GoTo 0
      If (iEnd >= iStart) And Err.Number = 0 Then
         lcHDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
         lHDC = CreateCompatibleDC(lcHDC)
         If (lHDC <> 0) Then
            lSizeX = (iEnd - iStart + 1) * m_lIconSizeX
            lhBmp = CreateCompatibleBitmap(lcHDC, lSizeX, m_lIconSizeY)
            If (lhBmp <> 0) Then
               lhBmpOld = SelectObject(lHDC, lhBmp)
               If (lhBmpOld <> 0) Then
                  lColor = TranslateColor(oBackColor)
                  tR.Bottom = m_lIconSizeY
                  tR.Right = lSizeX
                  hBr = CreateSolidBrush(lColor)
                  FillRect lHDC, tR, hBr
                  DeleteObject hBr
                  For iImgIndex = iStart To iEnd
                     ImageList_Draw m_hIml, ItemIndex(vKeys(iImgIndex), bForceLoadFromDisk), lHDC, (iImgIndex - iStart) * m_lIconSizeX, 0, ILD_TRANSPARENT
                  Next iImgIndex
                  SelectObject lHDC, lhBmpOld
                  Set ImagePictureStrip = BitmapToPicture(lhBmp)
               Else
                  DeleteObject lhBmp
               End If
            End If
            DeleteDC lHDC
            DeleteDC lcHDC
         End If
      End If
   End If

End Function

Public Function IconToPicture(ByVal hIcon As Long) As IPicture

   If hIcon = 0 Then Exit Function

   ' This is all magic if you ask me:
   Dim NewPic           As Picture, PicConv As PictDesc, IGuid As Guid

   PicConv.cbSizeofStruct = Len(PicConv)
   PicConv.picType = vbPicTypeIcon
   PicConv.hImage = hIcon

   ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
   With IGuid
      .Data1 = &H7BF80980
      .Data2 = &HBF32
      .Data3 = &H101A
      .Data4(0) = &H8B
      .Data4(1) = &HBB
      .Data4(2) = &H0
      .Data4(3) = &HAA
      .Data4(4) = &H0
      .Data4(5) = &H30
      .Data4(6) = &HC
      .Data4(7) = &HAB
   End With
   OleCreatePictureIndirect PicConv, IGuid, True, NewPic

   Set IconToPicture = NewPic

End Function

Public Function BitmapToPicture(ByVal hBmp As Long) As IPicture

   If (hBmp = 0) Then Exit Function

   Dim NewPic           As Picture, tPicConv As PictDesc, IGuid As Guid

   ' Fill PictDesc structure with necessary parts:
   With tPicConv
      .cbSizeofStruct = Len(tPicConv)
      .picType = vbPicTypeBitmap
      .hImage = hBmp
   End With

   ' Fill in IDispatch Interface ID
   With IGuid
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
   End With

   ' Create a picture object:
   OleCreatePictureIndirect tPicConv, IGuid, True, NewPic

   ' Return it:
   Set BitmapToPicture = NewPic

End Function

Public Function TranslateColor(ByVal clr As OLE_COLOR, _
   Optional hPal As Long = 0) As Long
   If OleTranslateColor(clr, hPal, TranslateColor) Then
      TranslateColor = CLR_INVALID
   End If
End Function

Private Sub Class_Initialize()
   m_lIconSizeX = 16
   m_lIconSizeY = 16
End Sub

Private Sub Class_Terminate()
   Destroy
End Sub



'-----------------

0
What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

 

Author Comment

by:expertfan
ID: 17842160
hey thanks.

but this code is scary,

can someone please change this and post the working code which i can use.
0
 
LVL 14

Expert Comment

by:Shiju Sasidharan
ID: 17848447
Ok done, try this

Private Sub Command1_Click()
Dim oNdS As cCTreeViewNode
Dim oNdD As cCTreeViewNode
Dim sSource As String
Dim sDest As String
   
    sSource = "D:\Your_SourceFolder"
    sDest = "D:\Your_Dest_Folder"
   
    Set oNdS = vbalColumnTreeView1.Nodes.Add(, etvwFirst, sSource, "Folder1")
    Set oNdD = vbalColumnTreeView2.Nodes.Add(, etvwFirst, sDest, "Folder2")
   
    CompareFolders sSource, sSource, sDest, vbalColumnTreeView1, vbalColumnTreeView2, oNdS, oNdD
    CompareFolders sDest, sDest, sSource, vbalColumnTreeView2, vbalColumnTreeView1, oNdD, oNdS
    oNdS.Expanded = True
    oNdD.Expanded = True
End Sub
Private Sub CompareFolders(Path As String, SourcePath As String, DestPath As String, LvSource As vbalColumnTreeView, LvDest As vbalColumnTreeView, SourceNode As cCTreeViewNode, DestNode As cCTreeViewNode)
Dim oFso, oFld, oTFld
Dim oNd  As cCTreeViewNode
Dim oNdSource As cCTreeViewNode
Dim oNdDest  As cCTreeViewNode
Dim sPath As String
    Set oFso = CreateObject("Scripting.FileSystemObject")
'On Error Resume Next 'Uncomment this line to handle permission denied error
    If Not oFso.FolderExists(Path) Then
        Set oFso = Nothing
        Exit Sub
    End If
    Set oFld = oFso.GetFolder(Path)
    Set oNd = SourceNode
    Set oNdDest = DestNode
    For Each oTFld In oFld.SubFolders
        If Not LvSource.Nodes.Exists(oTFld.Path) Then
            Set oNdSource = oNd.AddChildNode(oTFld.Path, oTFld.Name)
        Else
            Set oNdSource = LvSource.Nodes.Item(oTFld.Path)
        End If
        sPath = Replace(oTFld.Path, SourcePath, "")
        sPath = DestPath & sPath
       
        If LvDest.Nodes.Exists(sPath) Then
            Set oNdDest = LvDest.Nodes.Item(sPath)
        Else
            Set oNdDest = LvDest.Nodes.Add(DestNode, etvwChild, sPath, oTFld.Name)
        End If
        If Not oFso.FolderExists(sPath) Then oNdDest.ForeColor = vbRed
               
        CompareFolders oTFld.Path, SourcePath, DestPath, LvSource, LvDest, oNdSource, oNdDest
        DoEvents
    Next
    Set oFso = Nothing
    Err.Clear
End Sub
0
 

Author Comment

by:expertfan
ID: 17848505
hi shijusn,

i am seeing a "union of subfolders" of both the source-folder and dest-folder.....i am not seeing the "missing" text respectively.
0
 
LVL 14

Expert Comment

by:Shiju Sasidharan
ID: 17848667
ya i made missing them in red color
0
 

Author Comment

by:expertfan
ID: 17848687
i checked that the execution goes thru' the line for setting forecolor to red, but finally what i see is all black color rows.

please add a second column which will have a comment 'missing'
0
 
LVL 14

Expert Comment

by:Shiju Sasidharan
ID: 17848714
>>but finally what i see is all black color rows.

here i am getting missing items in red color.
Can you please provied the entire code you tried
0
 

Author Comment

by:expertfan
ID: 17848720
same as what you posted....but just changed the folder names

------------------------

Private Sub Command1_Click()
Dim oNdS As cCTreeViewNode
Dim oNdD As cCTreeViewNode
Dim sSource As String
Dim sDest As String
   
    sSource = "D:\test\"
    sDest = "D:\test-output\"
   
    Set oNdS = vbalColumnTreeView1.Nodes.Add(, etvwFirst, sSource, "Folder1")
    Set oNdD = vbalColumnTreeView2.Nodes.Add(, etvwFirst, sDest, "Folder2")
   
    CompareFolders sSource, sSource, sDest, vbalColumnTreeView1, vbalColumnTreeView2, oNdS, oNdD
    CompareFolders sDest, sDest, sSource, vbalColumnTreeView2, vbalColumnTreeView1, oNdD, oNdS
   
    oNdS.Expanded = True
    oNdD.Expanded = True
   
End Sub

Private Sub CompareFolders(Path As String, SourcePath As String, DestPath As String, LvSource As vbalColumnTreeView, LvDest As vbalColumnTreeView, SourceNode As cCTreeViewNode, DestNode As cCTreeViewNode)
Dim oFso, oFld, oTFld
Dim oNd  As cCTreeViewNode
Dim oNdSource As cCTreeViewNode
Dim oNdDest  As cCTreeViewNode
Dim sPath As String
    Set oFso = CreateObject("Scripting.FileSystemObject")
'On Error Resume Next 'Uncomment this line to handle permission denied error
    If Not oFso.FolderExists(Path) Then
        Set oFso = Nothing
        Exit Sub
    End If
    Set oFld = oFso.GetFolder(Path)
   
    Set oNd = SourceNode
    Set oNdDest = DestNode
   
    For Each oTFld In oFld.SubFolders
        If Not LvSource.Nodes.Exists(oTFld.Path) Then
            Set oNdSource = oNd.AddChildNode(oTFld.Path, oTFld.Name)
        Else
            Set oNdSource = LvSource.Nodes.Item(oTFld.Path)
        End If
        sPath = Replace(oTFld.Path, SourcePath, "")
        sPath = DestPath & sPath
       
        If LvDest.Nodes.Exists(sPath) Then
            Set oNdDest = LvDest.Nodes.Item(sPath)
        Else
            Set oNdDest = LvDest.Nodes.Add(DestNode, etvwChild, sPath, oTFld.Name)
        End If
       
        If Not oFso.FolderExists(sPath) Then
            oNdDest.ForeColor = vbRed
        End If
               
        CompareFolders oTFld.Path, SourcePath, DestPath, LvSource, LvDest, oNdSource, oNdDest
        DoEvents
    Next
    Set oFso = Nothing
    Err.Clear
End Sub
0
 
LVL 14

Expert Comment

by:Shiju Sasidharan
ID: 17848746
Private Sub Form_Load()
    vbalColumnTreeView1.Columns.Add "Col1", "Missing Entries"
    vbalColumnTreeView2.Columns.Add "Col1", "Missing Entries"
    vbalColumnTreeView1.Columns.Item(1).Width = 200
    vbalColumnTreeView1.Columns.Item(2).Width = 200
    vbalColumnTreeView2.Columns.Item(1).Width = 200
    vbalColumnTreeView2.Columns.Item(2).Width = 200
End Sub
Private Sub Command1_Click()
Dim oNdS As cCTreeViewNode
Dim oNdD As cCTreeViewNode
Dim sSource As String
Dim sDest As String
   
    sSource = "D:\test"
    sDest = "D:\test-output"
   
    vbalColumnTreeView1.Nodes.Clear
    vbalColumnTreeView2.Nodes.Clear
   
    Set oNdS = vbalColumnTreeView1.Nodes.Add(, etvwFirst, sSource, "Folder1")
    Set oNdD = vbalColumnTreeView2.Nodes.Add(, etvwFirst, sDest, "Folder2")
   
    CompareFolders sSource, sSource, sDest, vbalColumnTreeView1, vbalColumnTreeView2, oNdS, oNdD
    CompareFolders sDest, sDest, sSource, vbalColumnTreeView2, vbalColumnTreeView1, oNdD, oNdS
    oNdS.Expanded = True
    oNdD.Expanded = True
End Sub
Private Sub CompareFolders(Path As String, SourcePath As String, DestPath As String, LvSource As vbalColumnTreeView, LvDest As vbalColumnTreeView, SourceNode As cCTreeViewNode, DestNode As cCTreeViewNode)
Dim oFso, oFld, oTFld
Dim oNd  As cCTreeViewNode
Dim oNdSource As cCTreeViewNode
Dim oNdDest  As cCTreeViewNode
Dim sPath As String
    Set oFso = CreateObject("Scripting.FileSystemObject")
'On Error Resume Next 'Uncomment this line to handle permission denied error
    If Not oFso.FolderExists(Path) Then
        Set oFso = Nothing
        Exit Sub
    End If
    Set oFld = oFso.GetFolder(Path)
    Set oNd = SourceNode
    Set oNdDest = DestNode
    For Each oTFld In oFld.SubFolders
        If Not LvSource.Nodes.Exists(oTFld.Path) Then
            Set oNdSource = oNd.AddChildNode(oTFld.Path, oTFld.Name)
        Else
            Set oNdSource = LvSource.Nodes.Item(oTFld.Path)
        End If
        sPath = Replace(oTFld.Path, SourcePath, "")
        sPath = DestPath & sPath
       
        If LvDest.Nodes.Exists(sPath) Then
            Set oNdDest = LvDest.Nodes.Item(sPath)
        Else
            Set oNdDest = LvDest.Nodes.Add(DestNode, etvwChild, sPath, oTFld.Name)
        End If
        If Not oFso.FolderExists(sPath) Then
            oNdDest.ForeColor = vbRed
            oNdDest.SubItem(1).Text = "**Missing**"
        End If
               
        CompareFolders oTFld.Path, SourcePath, DestPath, LvSource, LvDest, oNdSource, oNdDest
        DoEvents
    Next
    Set oFso = Nothing
    Err.Clear
End Sub
0
 

Author Comment

by:expertfan
ID: 17863940
runtime error 91
object variable or with block variable not set...

-------------------------
i got this error at form load first line

    vbalColumnTreeView1.Columns.Add "Col1", "Missing Entries"

--------------------------
the control names are "vbalColumnTreeView1" and "vbalColumnTreeView2" so the names are not a problem.
0
 
LVL 14

Accepted Solution

by:
Shiju Sasidharan earned 500 total points
ID: 17878588
here i am not gettting any error

Please make sure that following files are registered on your machine

1.   SSubTmr6.dll
2.   ISHF_Ex.tlb
3.   OLEGUIDS.TLB
0
 

Author Comment

by:expertfan
ID: 17878648
shijusn,

you were right, that was the problem.....this works great !!
0
 
LVL 14

Expert Comment

by:Shiju Sasidharan
ID: 17878726
:-) Thank you for the Grade
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now