Create File Explorer in VBA with BSListView controls, BSImageList in BSAC controls
In VBA, do it step by step:
Step 1: Create a Userform
Make sure that you have installed Add-in A-Tools (version 9.1.0.5 or later) or BSAC.ocx activex controls (version 2.0.0.7 or later) before performing Step 2
Step 2: Click on the Userform, view the "Toolbox" window, right click on the "Controls" tab => "Import Page", select the "ImportToToolbox.pag" file (Download)
(Only do Step 2 if you do not see the BSAC controls on the Toolbox window)
Step 3: Drag the controls to the Userform: BSComboBox (cbView), BSListView (BSListView1), BSButton (cmdSelectFolder), BSEdit(edtPath), BSImageList (iml16), BSImageList (iml32)
Step 4: Right click on the Userform -> View the Code. Now you have the widow to edit the code. Copy the code below:
'-------BEGIN COPY
'Author: Nguyen Duy Tuan - http://atoolspro.com OR http://bluesofts.net
' Mail: duytuan@bluesofts.net - Tel: (84) 904210337
Option Explicit
Dim hwnd
'--------------------------------------------------------------
Private Sub BSListView1_OnItemDblClick(ByVal Item As BSAC.BSListItem)
ShellExecute hwnd, "OPEN", edtPath.Text & "\" & Item.Text
End Sub
'--------------------------------------------------------------
Private Sub cbView_OnSelect()
BSListView1.View = cbView.ItemIndex
End Sub
'--------------------------------------------------------------
Private Sub cmdSelectFolder_OnClick()
Dim sPath As String, Params As TBSBrowseForFolderParams
Params.NewFolderButton = True
Params.Title = "Please select folder:"
'If BrowseForFolder(sPath, "Please select folder:") Then
If BrowseForFolderEx(Params) Then
sPath = Params.Result
edtPath.Text = sPath
'Add folder and files to BSListView
BSListView1.Items.Clear
GetAllFiles sPath, True 'Get Folder
GetAllFiles sPath, False 'Get Files
End If
End Sub
'--------------------------------------------------------------
Private Sub GetAllFiles(sPath As String, ByVal GetFolder As Boolean)
Dim Files, bf As New BSFunctions
Dim cl As BSListColumn, li As BSListItem, Idx&, Ext$
Dim I&, J&, s$
Dim hIcon, hsmIcon
' Type of Files is array 2D= (1..m, 1...n)
Files = GetFiles(Path:=sPath, Folder:=GetFolder, SubFolder:=False)
'Add column header
If BSListView1.Columns.Count = 0 Then 'Create columns for the first time
For J = LBound(Files, 2) To UBound(Files, 2)
If J 2 Then 'ignore index 2
BSListView1.Columns.Add Files(LBound(Files, 1), J)
End If
Next J
BSListView1.AutoColumns 'resize columns
End If
'Add items
BSListView1.Items.BeginUpdate
For I = LBound(Files, 1) + 1 To UBound(Files, 1) 'Get rows
Ext = Files(I, 3) 'It is key to find image
If GetFolder Then
Ext = "folder"
ElseIf Ext = ".ico" Then
Idx = iml32.ListImages.AddIcon(sPath & "\" & Files(I, 1)) 'Create and Add icon to Imagelist size 32
Idx = iml16.ListImages.AddIcon(sPath & "\" & Files(I, 1)) 'Create and Add icon to Imagelist size 16
ElseIf Ext ".exe" And Ext ".ico" Then
Idx = iml16.ListImages.IndexOf(Ext)
Else
Idx = -1 'let find icon
End If
If Idx = -1 Then 'not exists then add new icon for file type
If GetAssociatedIcon(sPath & "\" & Files(I, 1), hIcon, hsmIcon) > 0 Then
Idx = iml32.ListImages.AddIcon(hIcon, Ext) 'Add icon to Imagelist size 32
iml16.ListImages.AddIcon hsmIcon, Ext 'Add icon to Imagelist size 16
End If
End If
Set li = BSListView1.Items.Add(Files(I, 1), Idx)
For J = 3 To UBound(Files, 2) 'Get columns
li.SubItems.Add Files(I, J)
Next J
Next I
BSListView1.Items.EndUpdate
End Sub
'--------------------------------------------------------------
Private Sub UserForm_Initialize()
Dim hIcon, hIcon2
hwnd = GetHwnd(Me)
'Set resize userform, min, max button
SetWindowLong hwnd, GWL_STYLE, GetWindowLong(hwnd, GWL_STYLE) Or _
WS_SIZEBOX Or WS_MAXIMIZEBOX Or WS_MINIMIZEBOX
iml16.PicWidth = 16
iml16.PicHeight = 16
iml32.PicWidth = 48
iml32.PicHeight = 48
hIcon = ExtractIcon(0, GetSysDir & "\shell32.dll", 3) 'Icon Folder
hIcon2 = ExtractIcon(0, GetSysDir & "\shell32.dll", 3) 'Icon Folder
iml16.ListImages.AddIcon hIcon, "folder"
iml32.ListImages.AddIcon hIcon2, "folder"
'ListView
BSListView1.View = vsReport
BSListView1.hSmallImageList = iml16.hImageList
BSListView1.hImageList = iml32.hImageList
BSListView1.RowSelect = True
BSListView1.MultiSelect = True
BSListView1.AllowCustomSort = True
BSListView1.lpfnCustomSort = GetFuncPtr(AddressOf SortByColumn)
'Add combobox View
cbView.Items.Add "vsIcon"
cbView.Items.Add "vsSmallIcon "
cbView.Items.Add "vsList"
cbView.Items.Add "vsReport"
cbView.ItemIndex = 3 'vsReport
End Sub
'--------------------------------------------------------------
Private Sub UserForm_Resize()
If Width - BSListView1.Left > 0 Then
BSListView1.Width = Width - BSListView1.Left - 17
End If
If Height - BSListView1.Top > 0 Then
BSListView1.Height = Height - BSListView1.Top - 33
End If
'Caption = Width - BSListView1.Left - 8 & " : " & BSListView1.nWidth
End Sub
'-------END COPY
(*) Go to menu Tools->References
Select/check "AddinATools.dll" to use GetFiles() function
Step 5: Go to menu "Insert"->Module. Now you have the widow to edit the code. Copy the code below:
'-------BEGIN COPY
Option Explicit
' RUN IF DECLARE:
' BSListView1.AllowCustomSort = True
' BSListView1.lpfnCustomSort = GetFuncPtr(AddressOf SortByColumn)
' SortByColumn run when click on column to sort
#If VBA7 Then
Function SortByColumn(ByVal lParam1 As LongPtr, ByVal lParam2 As LongPtr, ByVal Col As Long) As Long
#Else
Function SortByColumn(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal Col As Long) As Long
#End If
Dim Item1 As BSListItem, Item2 As BSListItem
Dim v1, v2
Set Item1 = UserForm1.BSListView1.Items.GetItemFromLPARAM(lParam1)
Set Item2 = UserForm1.BSListView1.Items.GetItemFromLPARAM(lParam2)
'Get data from BSListView
If Col = 0 Then
v1 = Item1.Text
v2 = Item2.Text
Else
v1 = Item1.SubItems(Col - 1)
v2 = Item2.SubItems(Col - 1)
End If
'Convert data
Select Case Col
Case 2, 6:
v1 = CDbl(v1)
v2 = CDbl(v2)
Case 3, 4, 5:
v1 = CDate(v1)
v2 = CDate(v2)
End Select
'Compare
If v1 = v2 Then
SortByColumn = 0
ElseIf v1 < v2 Then
SortByColumn = -1
Else
SortByColumn = 1
End If
If Not UserForm1.BSListView1.SortIsAscending Then
SortByColumn = -SortByColumn
End If
Set Item1 = Nothing
Set Item2 = Nothing
End Function
'--------------------------------------------------------------
Sub ShowExlorer()
UserForm1.Show
End Sub
'-------END COPY
Support online: https://www.facebook.com/groups/hocexcel/
'--------------------------------------------------------------