Extracting file information: Icon and Ownership

[imported_unknown]

Hi guys,

This is may first post and hope to get ideas, as well as give ideas, so that we can all benefit from them.

- - - -

I work at a multinational company and we often have to deal with many folders, sub-folders, hard drives, network drives, removable drives, USB drives, CDs, etc. Sometimes it's a complete mess and waste of space and time searching for files (not to mention redundant and duplicate files).

Since Microsoft has never provided us with a "Print folder contents" or "List folder" commands on Windows Explorer, I've performed some research on the "File System Object", which can be accessed by VBA, VB, VBScript, etc. I found many interesting possibilities.

Since then, I'm creating a "List folder contents" macro in Excel. Why Excel? Because of its endless possibilities of formatting, reporting, etc. This macro will list all subfolders and files from any given drive or folder, along with their common properties: size, dates, attributes, etc. and generate a neat listing on a worksheet, which can then be printed or just saved.

Now, I'm posting two questions:


(1) - FILE ICONS

After searching a few sites and references I also found a way to "extract" the icon from a file. However, the solutions using API calls were for VB projects, rather than VBA. I've tried some code adaptations, but coudn't come up with a solution to this due to the lack of examples or further explanations.

The mission: from a file object, get the small icon (or large icon) and paste it on a worksheet cell to make the report more "Windows-like".

As a reference to you: http://www.allapi.net/apilist/FFF4B6DE1075139CC7AFCCA45CDF2A2C.html


(2) FILE OWNERSHIP

On our network it's very common for the users to keep all files on the network drives because of the daily backups. Since each user has a restricted space in megabytes, the need for extra space is very common.

As a general guideline our Help Desk staff suggests that older or unused files should be removed or transferred to removable media in order to free up some space. Since many users share a department's directory, it's hard to know who did what.

We have a Novell Netware 4.12 with WinNT(SP6), Win98 and WinXP workstations. We're planning to upgrade Netware and Windows (2000 or XP-Pro) next year.

One of the main reasons of this folder listing macro is to identify particular user's files through Novell's OWNER attribute, but I coudn't figure out how to obtain this information from a file. Perhaps there's a Novell API call I could use, or even another way to get the "ownership" of each file and folder, such as system variables...

- - -

Well, I hope to have some ideas on these issues.

For now: thanx.

 

[Legacy 98055]

Hi fcnavarro.
This seemed to be a fun project so I gave it a shot. I found plenty of examples on the web pertaining to VB and not VBA as you mentioned. I tried to adapt the code to VBA and came close but no cigar. The code for the VB project is listed below as "VB CODE". Maybe someone can give it a shot.
However, I was able to compile the VB code into a dll which can easily be used in VBA.
I mailed the dll to you. Follow these steps.

<pre>
1. Place the email attachements into whatsoever
folder you wish. If the workbook is to
be distributed via LAN or WAN, I would
place it on a server which is accessible
to all of your users. If distributed
without network support, then store the
dll with the workbook.

2. Set a reference to the gIcon library in your
VBA IDE. It should self-register.

3. The function accepts the following parameters.

The complete path of the file you wish to
extract the icon.

The complete path of the file which will be saved
from the icon. Reccomend saving as a bitmap(bmp)

Large icon as TRUE or FALSE for a small icon

The BackColor of the picture to be saved.

The following example should get you on the right track.
The program takes the paramaters, gets the icon, saves it
as a bitmap, inserts the newly created bitmap into your
spreadsheet, and then deletes the bitmap from file.
You can play around with the position of the insert and
easily incorporate the examples into a loop with your
current code. Place all in any standard module.

'#############################################################
WORKBOOK CODE

Sub Example()
Dim ProgramPathToExtractIcon As String
Dim NewBitMapSaveAsPath As String
Dim IconBackGroundColor As Long
Dim LargeIcon As Boolean

ProgramPathToExtractIcon = Application.Path & "" & "Excel.exe"
NewBitMapSaveAsPath = ThisWorkbook.Path & "" & "Excel.bmp"
IconBackGroundColor = vbWhite
LargeIcon = True

If Not GetPicture(ProgramPathToExtractIcon, NewBitMapSaveAsPath, _
IconBackGroundColor, LargeIcon) Then
MsgBox "Failed to extract and convert icon..."
Else
With ActiveSheet.Pictures.Insert(NewBitMapSaveAsPath)
.ShapeRange.Left = 299.25
.ShapeRange.Top = 13.5
End With
Kill NewBitMapSaveAsPath
End If

End Sub


Function GetPicture(IconFromPath As String, IconSavePath As String, BackClr As Long, _
LargeIcon As Boolean)
Dim ib As New GetPik
GetPicture = ib.GetIcon(IconFromPath, IconSavePath, BackClr, LargeIcon)
Set ib = Nothing
End Function
'#############################################################

Tom



This is the original code. Maybe someone can remove the need for using
a dll file by adapting this to VBA.

'Module 1

Private Type PicBmp
Size As Long
tType As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Declare Function ExtractIconEx Lib "shell32.dll" _
Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal _
nIconIndex As Long, phiconLarge As Long, phiconSmall As _
Long, ByVal nIcons As Long) As Long

Private Declare Function DestroyIcon Lib "user32" (ByVal _
hicon As Long) As Long

Public Function GetIconFromFile(FileName As String, _
IconIndex As Long, UseLargeIcon As Boolean) As Picture

'Parameters:
'FileName - File (EXE or DLL) containing icons
'IconIndex - Index of icon to extract, starting with 0
'UseLargeIcon-True for a large icon, False for a small icon
'Returns: Picture object, containing icon

Dim hlargeicon As Long
Dim hsmallicon As Long
Dim selhandle As Long

'IPicture requires a reference to "Standard OLE Types."
Dim pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID

If ExtractIconEx(FileName, IconIndex, hlargeicon, _
hsmallicon, 1) > 0 Then

If UseLargeIcon Then
selhandle = hlargeicon
Else
selhandle = hsmallicon
End If

'Fill in with IDispatch Interface ID.
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'Fill Pic with necessary parts.
With pic
.Size = Len(pic) 'Length of structure.
.tType = vbPicTypeIcon 'Type of Picture (bitmap).
.hBmp = selhandle 'Handle to bitmap.
End With

'Create Picture object.
Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)

'Return the new Picture object.
Set GetIconFromFile = IPic

DestroyIcon hsmallicon
DestroyIcon hlargeicon

End If
End Function

'Form1 with Picture1 and Command1

Private Sub Command1_Click()
Set Picture1.Picture = GetIconFromFile("C:Documents and SettingsAdministratorDesktopRT_User.exe", _
0, True)
SavePicture Picture1.Image, "C:Documents and SettingsAdministratorDesktopTestIcon.bmp"
End Sub

</pre>

 

[Legacy 98055]

As for number two.
Found this as is from here:
http://www.vb2themax.com/Item.asp?PageID=CodeBank&Cat=140&ID=396

Only works on NTFS partitions.
Tested out fine using VBA.

<pre>
Option Explicit

Private Declare Function GetFileSecurity Lib "advapi32.dll" Alias _
"GetFileSecurityA" (ByVal lpFileName As String, ByVal RequestedInformation _
As Long, pSecurityDescriptor As Byte, ByVal nLength As Long, _
lpnLengthNeeded As Long) As Long
Private Declare Function GetSecurityDescriptorOwner Lib "advapi32.dll" _
(pSecurityDescriptor As Any, pOwner As Long, lpbOwnerDefaulted As Long) As _
Long
Private Declare Function LookupAccountSid Lib "advapi32.dll" Alias _
"LookupAccountSidA" (ByVal lpSystemName As String, ByVal Sid As Long, _
ByVal name As String, cbName As Long, ByVal ReferencedDomainName As String, _
cbReferencedDomainName As Long, peUse As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias _
"GetWindowsDirectoryA" (ByVal lpBuffer As String, _
ByVal nSize As Long) As Long

Const OWNER_SECURITY_INFORMATION = &H1
Const ERROR_INSUFFICIENT_BUFFER = 122&
Const MAX_PATH = 255

' return the name of the file owner
'
' runs over Windows NT or 2000, and works only with files in NTFS partitions

Function GetFileOwner(ByVal szfilename As String) As String
Dim bSuccess As Long ' Status variable
Dim sizeSD As Long ' Buffer size to store Owner's SID
Dim pOwner As Long ' Pointer to the Owner's SID
Dim ownerName As String ' Name of the file owner
Dim domain_name As String ' Name of the first domain for the owner
Dim name_len As Long ' Required length for the owner name
Dim domain_len As Long ' Required length for the domain name
Dim sdBuf() As Byte ' Buffer for Security Descriptor
Dim nLength As Long ' Length of the Windows Directory
Dim deUse As Long ' Pointer to a SID_NAME_USE enumerated type
' indicating the type of the account

' Call GetFileSecurity the first time to obtain the size of the buffer
' required for the Security Descriptor.
bSuccess = GetFileSecurity(szfilename, OWNER_SECURITY_INFORMATION, 0, 0&, _
sizeSD)
' exit if any error
If (bSuccess = 0) And (Err.LastDllError <> ERROR_INSUFFICIENT_BUFFER) Then _
Exit Function

' Create a buffer of the required size and call GetFileSecurity again
ReDim sdBuf(0 To sizeSD - 1) As Byte
' Fill the buffer with the security descriptor of the object specified by
' the
' filename parameter. The calling process must have the right to view the
' specified
' aspects of the object's security status.
bSuccess = GetFileSecurity(szfilename, OWNER_SECURITY_INFORMATION, sdBuf(0), _
sizeSD, sizeSD)
' exit if error
If bSuccess = 0 Then Exit Function

' Obtain the owner's SID from the Security Descriptor, exit if error
bSuccess = GetSecurityDescriptorOwner(sdBuf(0), pOwner, 0&)
If bSuccess = 0 Then Exit Function

' Retrieve the name of the account and the name of the first domain on
' which this SID is found. Passes in the Owner's SID obtained previously.
' Call LookupAccountSid twice, the
' first time to obtain the required size of the owner and domain names.
bSuccess = LookupAccountSid(vbNullString, pOwner, ownerName, name_len, _
domain_name, domain_len, deUse)
' exit if any error
If (bSuccess = 0) And (Err.LastDllError <> ERROR_INSUFFICIENT_BUFFER) Then _
Exit Function

' Allocate the required space in the name and domain_name string variables.
' Allocate 1 byte less to avoid the appended NULL character.
ownerName = Space(name_len - 1)
domain_name = Space(domain_len - 1)

' Call LookupAccountSid again to actually fill in the name of the owner
' and the first domain.
bSuccess = LookupAccountSid(vbNullString, pOwner, ownerName, name_len, _
domain_name, domain_len, deUse)
If bSuccess = 0 Then Exit Function

' we've found a result
GetFileOwner = ownerName

End Function

</pre>

Tom

 

[Juan Pablo González]

Well Tom, you have surely impressed me.

 

[Legacy 98055]

Juan
Don't want to lead anyone astray...
You must mean my web searching abilities? I didn't write this I just edited it.
Tom

 

[imported_unknown]

Hi Tom.

First of all, thank you very much for your prompt response. Yesterday I played around with the code you posted as well as the files you sent me.

At first it didn't work. I was getting blank pictures pasted on a worksheet. I thought it could be something related to my localized version os Excel, which is in Portuguese. But it coudn't be because most of the VBA environment (except for menus and help files) is in English.

As soon as I took a closer look at your listing I realized two lines had a blank string concatenated to the file paths. After a little Debug.Print-ing I noticed a missing backslash. I bet it was due to some cutting and pasting among browser windows.

So, I changed these two lines from this...

ProgramPathToExtractIcon = Application.Path & "" & "Excel.exe"
NewBitMapSaveAsPath = ThisWorkbook.Path & "" & "Excel.bmp"

To this...

ProgramPathToExtractIcon = Application.Path & Chr(92) & "Excel.exe"
NewBitMapSaveAsPath = ThisWorkbook.Path & Chr(92) & "Excel.bmp"

I didn't include the backslash because I was not sure this message would be posted correctly with that character.

Well Tom, thanks again and I will now start working a little on your reply to my second question.

 

[imported_unknown]

Tom,

The listing you found for my question #2 worked fine on my WinXP-Home, showing files that belong to "All Users" and files that belong to me only.

I'll test it tomorrow morning at the office on our network. Tell you later, OK?

Thanx again!

 

[FeltoltElek]

Hi guys!

is it possible to receive the above dll file by email?

Thanx.