Newsgroup: it.comp.appl.access
Titolo: Ottenere l'icona di un file

Vorrei ottenere l'icona associata ad un file su disco in modo tale da
poterla, per esempio, caricare in una picturebox.
E' possibile?
Grazie
Luigi

 ha scritto nel messaggio 
news:dk2ud2luvn8jr4f1p...@4ax.com...

Sě č possibile se mastichi di API e affini.
Scherzi a parte, qui il piů famoso apicultore č Alex. Vediamo se č in 
ascolto.
Ciao, Carlo 

 Ciao, Carlo
Presente.
Premesso che VBA(Access) non dispone di PictureBox(ma forse intendevi
controllo immagine) pertanto le cose si complicano in modo evidente
obbligando a passare per una STDPicture non proprio semplice da
gestire...!
Io in ogni caso con l'aiuto di Serge Gavrilov ho fatto una cosa di
questo tipo peraltro presente in ArchiDoc, ma che magari posso
pubblicare StandAlone:
Per richiamarla faccio così:
 Call SetIcon(Me!nomeControlloPicture,PathFileName)
Da mettere in un Modulo:
Option Compare Database
Option Explicit
'***********************************************************************
'  This CODE is for kind courtesy of:
'  Serge Gavrilov
'***********************************************************************
Const GWL_HINSTANCE = (-6)
Private Declare Function ExtractIcon Lib "shell32.dll" _
        Alias "ExtractIconA" _
        (ByVal hInst As Long, _
         ByVal lpszExeFileName As String, _
         ByVal nIconIndex As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias
"GetWindowLongA" _
        (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" _
        Alias "ExtractAssociatedIconA" _
        (ByVal hInst As Long, _
         ByVal lpIconPath As String, _
         ByRef lpiIcon As Integer) As Long
Private Declare Function DestroyIcon Lib "user32" _
        (ByVal hIcon As Long) As Long
'***********************************************************************
'***********************************************************************
'***********************************************************************
'  Questa funzione ritorna la Dir temporanea di Sistema
Private Declare Function GetTempPath Lib "kernel32" Alias _
                        "GetTempPathA" (ByVal nBufferLength As Long, _
                        ByVal lpBuffer As String) As Long
'***********************************************************************
Private Type ICONTYPE
    cbSizeOfStruct As Long
    picType As Long
    hIcon As Long
    dummy1 As Long
    dummy2 As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    BData1 As Byte
    BData2 As Byte
    BData3 As Byte
    BData4 As Byte
    BData5 As Byte
    BData6 As Byte
    BData7 As Byte
    BData8 As Byte
End Type
Private Declare Function OleInitialize Lib "OLE32.DLL" ( _
    lp As Any) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (
_
    picDesc As ICONTYPE, iid As GUID, ByVal fOwn As Boolean, _
    iPic As IPictureDisp) As Long
Private Declare Sub OleUninitialize Lib "OLE32.DLL" ()
Private Const PICTYPE_ICON = 3
'Private Declare Function GetCursor Lib "user32" () As Long
Private Function GetIcoPicture(hIcon As Long) As IPictureDisp
    Dim picDesc As ICONTYPE
    Dim iid As GUID
    Dim pic As IPictureDisp
    Dim hIconLarge As Long
'    hIcon = GetCursor()
    ' Set PICTDESC to convert HICONs.
    picDesc.cbSizeOfStruct = Len(picDesc)
    picDesc.picType = PICTYPE_ICON
    picDesc.hIcon = hIcon
    ' Fill in magic IPicture GUID
    '{7BF80980-BF32-101A-8BBB-00AA00300CAB}
    ' IPictureDisp ID is:
    ' 0x7Bf80981,0xBF32,0x101A,0x8B,0xBB,0x00,0xAA,
    ' 0x00,0x30,0x0C,0xAB
    iid.Data1 = &H7BF80981
    iid.Data2 = &HBF32
    iid.Data3 = &H101A
    iid.BData1 = &H8B
    iid.BData2 = &HBB
    iid.BData3 = &H0
    iid.BData4 = &HAA
    iid.BData5 = &H0
    iid.BData6 = &H30
    iid.BData7 = &HC
    iid.BData8 = &HAB
    ' convert to IPictureDisp
    OleInitialize ByVal 0&
    OleCreatePictureIndirect picDesc, iid, True, pic
    OleUninitialize
    Set GetIcoPicture = pic
End Function
Public Function SetIcon(imgCtl As Access.Image, strPath As String) As
String
    Dim hInst As Long
    Dim hIcon As Long
    hInst = GetWindowLong(Application.hWndAccessApp, GWL_HINSTANCE)
    hIcon = ExtractAssociatedIcon(hInst, strPath, CLng(0))
    SavePicture GetIcoPicture(hIcon), tempPath & hIcon & ".ico"
    DestroyIcon hIcon
    imgCtl.Picture = tempPath & hIcon & ".ico"
    Kill tempPath & hIcon & ".ico"
End Function
Private Function tempPath() As String
    Dim strTemp As String
    strTemp = String(510, Chr$(0))
    GetTempPath 510, strTemp
    tempPath = Left$(strTemp, InStr(strTemp, Chr$(0)) - 1)
End Function
@Alex

@Alex
Perfetto Alessandro!
Sono riuscito ad adattare il codice alle mie esigenze e tutto funziona
bene.
L'unico neo č che le icone prodotte sono un po' diverse dalle
originali. Ma se non č possibile fare meglio, mi accontento cosě.
Grazie per l'aiuto
Luigi

 Luigi
L'unica differenza può risiedere nella dimensione e nella definizione
colori, ma questo è un limite della procedura OLE....!
Pubblicato articolo su questo argomento:
http://www.alessandrobaraldi.it/DettaglioFaq.asp?IdFAQ=252
Ciao
@Alex

@Alex
Sě, in effetti le icone risultano generalmente meno risolute e piů
sbiadite rispetto alle originali.
Comunque, per quello che devo fare io, va bene anche cosě.
Grazie
Luigi



Caro Alessandro, riprendo questo thread perchč andando a studiarmi un
po' la tua demo relativa alla gestione di alcuni controlli (treeview,
listview,..) senza OCX
(
http://www.alessandrobaraldi.it/DettaglioFaq.asp?IdFAQ=53
) 
ho notato che le icone che vengono estratte dai file su disco, sono
praticamente perfette, molto piů perfette di quelle che riesco ad
ottenere io col codice che tu hai postato in questo thread.
Come mai?
Grazie
Luigi

 Luigi
Quando si posta una domanda volendo già indirizzare chi legge verso
una
strada sbagliata si ottengono questi risultati....!!!!
;-)
Tu parlavi di PictureBox, e ti ho detto che non esistendo in Access
serve passare per
OLE convertendo in una struttura standard, con OCX tipo Tree e List
questo non serve., l'immagine ICO viene passata direttamente al
controllo ListView non perdendo così definizione...!
Riassumendo visto che non hai spiegato quello che dovevi fare realmente
la risposta
che hai ricevuto non era ottimizzata.
Next time prova ad essere meno criptico e definire nel suo insieme
l'esigenza.
@Alex

[CUT]

Sì Alex, forse hai ragione.
Nella mia richiesta iniziale avevo detto che avevo l'esigenza di
ottenere l'icona da un file e per semplificare il problema, avevo
detto di doverla porre in una picturebox perchè, nella mia ignoranza,
non pensavo che la cosa facesse differenza.
In realtà quello che dovevo fare era di inserirla in una listview
accanto al nome del file.
Se adesso tu fossi così gentile da fornirmi qualche chiarimento su
come realizzare la cosa, te ne sarei molto grato. Purtroppo dal codice
della demo non sono riuscito a capire molto.
Grazie
Luigi

 Luigi
Non c'è problema, dovrai aspettare che rientri a casa in tarda serata,
poi lo riprendo in mano e vedo di estrarti la parte che ti serve.
@Alex

@Alex
Grazie, sei molto gentile.
Luigi

Ciao Luigi, non ho avuto molto tempo, ed ho trovato una anomalia con la
quale
non ho potuto verificare a fondo.
Io però con gli OCX non ho molta familiarità ed ho dovuto fare delle
modifiche sostanziali al codice API.
In sostanza il codice che ti allego in VB6 funziona immediatamente, in
VBA non ho ben
capito ancora perchè ma dà qualche anomalia(non mi funziona)....!
Richiede 3 controlli:
1 Controllo ListView chiamato [lvFiles]
1 Controllo ImageList chiamato [imlFileIcons]
1 Controllo CommandButton chiamato [cmdGO]
E' talmente banale in VB6 che anche in VBA doveva andare.... la
chiamata su Click
del cmdButton cicla la Folder "C:\" e riepie l'imageList associandola
alla ListView
Private Const MAX_PATH = 260
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type PICTDESC
    cbSize As Long
    picType As Long
    hImage As Long
    Data1 As Long
    Data2 As Long
End Type
Private Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll"
(pPictDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As
Long, ppvObj As StdPicture) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias
"SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As
Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As
Long) As Long
Private Sub cmdGO_Click()
   RefreshFiles "C:\"
End Sub
'Purpose     :  Retrieves the default associated icon from a file
'Inputs      :  sFileName                           The full path and
name of the file to retrieve the icon of.
'Outputs     :  Returns the icon
Function FileExtractIcon(sFileName As String) As StdPicture
    Dim tPic As PICTDESC
    Dim tIDispatch As GUID
    Dim oPic As StdPicture
    Dim hIcon As Long
    Dim tFileInfo As SHFILEINFO
    Const SHGFI_ICON = &H100, SHGFI_DISPLAYNAME = &H200
    Const SHGFI_TYPENAME = &H400, SHGFI_SMALLICON = &H1
    'FYI, file attribute bits
    Const FILE_ATTRIBUTE_READONLY = &H1, FILE_ATTRIBUTE_HIDDEN = &H2
    Const FILE_ATTRIBUTE_SYSTEM = &H4, FILE_ATTRIBUTE_DIRECTORY = &H10
    Const FILE_ATTRIBUTE_ARCHIVE = &H20, FILE_ATTRIBUTE_NORMAL = &H80
    Const FILE_ATTRIBUTE_TEMPORARY = &H100
    On Error Resume Next
    'Extract File information
    Call SHGetFileInfo(sFileName, 0, tFileInfo, Len(tFileInfo),
SHGFI_DISPLAYNAME Or SHGFI_TYPENAME Or SHGFI_SMALLICON Or SHGFI_ICON)
    'Get the handle to the files icon
    hIcon = tFileInfo.hIcon
    'Initialise type
    With tPic
        .cbSize = Len(tPic)
        .picType = 3        'vbPicTypeIcon
        .hImage = hIcon
    End With
    'Fill IDispatch Interface ID,{00020400-0000-0000-C000-000000046}
    With tIDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    'Get Icon
    Call OleCreatePictureIndirect(tPic, tIDispatch, 0, oPic)
    'Return Icon
    Set FileExtractIcon = oPic
    On Error GoTo 0
End Function
'Purpose     :  Populates a listview with the files in a specified
directory
'Inputs      :  sPath                   The path to the files
'               lvFiles                 The listview to populate
'               imlFileIcons                 An image list to store the
icons
'               [sFileFilter]           A file filter string
'Outputs     :  Returns the icon
'Notes       :  eg Call RefreshFiles("C:\", lvFiles, imlFileIcons,"*")
Sub RefreshFiles(ByVal sPath As String, Optional sFileFilter As String
= "*")
    Dim oFileIcon As StdPicture, sFileName As String, sFileType As
String
    Dim bAddedImageList As Boolean, lThisColHeader As Long, lWidth As
Long
    On Error Resume Next
    If Right(sPath, 1) <> "\" Then
        sPath = sPath & "\"
    End If
    sFileName = Dir$(sPath & sFileFilter)
    lvFiles.View = lvwReport
    lWidth = lvFiles.Width / 10
    For lThisColHeader = lvFiles.ColumnHeaders.Count To 3
        Select Case lThisColHeader
        Case 1
            lvFiles.ColumnHeaders.Add , , "File Name", lWidth * 4
        Case 2
            lvFiles.ColumnHeaders.Add , , "File Size", lWidth * 3
        Case 3
            lvFiles.ColumnHeaders.Add , , "Last Modified", lWidth * 3
        End Select
    Next
    lvFiles.ListItems.Clear
    Do While Len(sFileName)
        sFileType = Right$(sFileName, 3)
        If imlFileIcons.ListImages(sFileType).Picture Is Nothing Then
            'Find icon associated with file
            Set oFileIcon = FileExtractIcon(sPath & sFileName)
            If oFileIcon Is Nothing = False Then
                'Add to icon image list
                imlFileIcons.ListImages.Add , sFileType, oFileIcon
                If bAddedImageList = False Then
                    'Initialise listview smallicons
                    lvFiles.SmallIcons = imlFileIcons
                    bAddedImageList = True
                End If
            End If
        End If
        'Add item to listview
        With lvFiles.ListItems.Add(, , sFileName, , sFileType)
            .SubItems(1) = Format(FileLen(sPath & sFileName) / 1024,
"#,##0") & "KB"
            .SubItems(2) = Format(FileDateTime(sPath & sFileName),
"dd/mmm/yyyy hh:mm")
        End With
        sFileName = Dir$
    Loop
End Sub
Nei prossimi giorni tempo permettendo faccio qualche indagine più
approfondita.
@Alex

@Alex
Caspita Alessandro, è proprio come dici tu!
Ho provato prima il tuo codice in VB6, e funziona benissimo.
Poi l'ho provato in Access. Mi si avvia, mi compare la listview e il
bottone di comando, ma quando clicco sul bottone di comando, la
listview non si popola. Comunque non compare nessun messaggio di
errore.
Comunque le icone prodotte sono talmente belle in confronto a quelle
che ottenevo col codice precedente che adesso non mi rassegnerò fino a
quando non avrai trovato l'inghippo!!! ;-)
Ti prego, appena avrai risolto il problema, fammelo sapere.
Infiniti grazie.
Luigi

 Luigi
Spero di riuscirci nel senso che non conoscendo bene gli OCX non è
detto
si riesca a sistemare, oltretutto non è dovuto ad un errore(come vedi
in VB6
è perfetto) qundi può essere un problema di gestione del controllo da
VBA
e trovarci il difetto non è detto sia fattibile.....
Vediamo che salta fuori....
@Alex

@Alex
Ok Alessandro, spero che alla fine riuscirai a risolvere il problema.
Io ieri sono stato due ore a fare tentativi, cambiando questo o
quello, inserendo punti di interruzione per esaminare il codice e lo
stato delle variabili man mano che avanzava, ma non ho cavato un ragno
dal buco. Eppure le immagini vengono aggiunte alla imagelist, prova ne
č che inserendo alla fine una istruzione del tipo
imlFileIcons.listimages.count
mi viene correttamente restituito il numero di immagini.
Oppure inserendo
imlFileIcons.listimages.item(i).key
mi viene correttamente restituita la chiave dell'iesimo item.
Non so proprio piů che pesci prendere.
Comunque se riprendi il problema in mano, fammi sapere le conclusioni
a cui giungi, siano esse risolutive o meno.
Grazie
Luigi

 Luigi
Ho fatto le stesse prove, e l'ImageList come hai già visto è
riempita, quello che
non capisco, ImageList a parte è perchè almeno non aggiunga gli Items
e SubItems
come semplice testo.....
Prima serve capire quello, poi le immagini, non vorrei che per le
immagini sia necessario
subclassare per impedire il Reset dovuto all'assegnazione
dell'imagelist durante
il riempimento, quindi Runtime e non a Design..., avevo letto qualcosa
tempo fà ma non lo trovo..., eventualmente provo a postare su un NG
americano per capire se la cosa è nota.
@Alex

come semplice testo.....
Caro Alessandro, se questo puņ aiutarti io ho provato a sostituire
alla riga di codice
With lvFiles.ListItems.Add(, , sFileName, , sFileType)
le righe
With lvFiles.ListItems.Add(, , sFileName)
       .ListItem.SmallIcon = sFileType
In tal caso, gli Items e i SubItems vengono aggiunti come semplice
testo senza icone.
Il problema quindi č proprio nelle icone.
Ciao
Luigi

 Luigi
La cosa è anomala, voglio dire in VB e VBA il controllo si dovrebbe
comportare
in modo equivalente, quello che può cambiare è la parte che lega il
VBA al controllo
e quindi metodi e proprietà dell'Oggetto...!
La prima cosa che non mi spiego è che in Access non sono esposte
proprietà che
sono esposte in VB proprio relative all'ImageList....
Ho postato il questito sul NG Americano perchè la cosa mi ha
incuriosito....
@Alex

@Alex
Grazie, attendiamo gli sviluppi.
Luigi