[Vista+] Code Snippet: Get and set the Rating (stars) of a file
In Explorer, things like Pictures and some other types have a 'Rating' property category that shows a 0-5 star rating. You can get and set this rating programmatically, and this also provides a basis for getting and setting other properties. Requires oleexp, v2.0 or higher.
Code:
Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Sub ILFree Lib "shell32" (ByVal pidl As Long)
Public Declare Function SHCreateItemFromIDList Lib "shell32" (ByVal pidl As Long, riid As UUID, ppv As Any) As Long
Public Function GetFileRating(sFile As String) As Long
'Returns the star rating of a file in number of stars
Dim pidl As Long
Dim isi As IShellItem2
Dim lp As Long
Dim pkRating As PROPERTYKEY '{64440492-4C8B-11D1-8B70-080036B11A03}, 9
DEFINE_PROPERTYKEY pkRating, &H64440492, CInt(&H4C8B), CInt(&H11D1), &H8B, &H70, &H8, &H0, &H36, &HB1, &H1A, &H3, 9
'first, get the shell item representing the file
pidl = ILCreateFromPathW(StrPtr(sFile))
Call SHCreateItemFromIDList(pidl, IID_IShellItem2, isi)
isi.GetUInt32 pkRating, lp 'it's a VT_UI4; 4-byte unsigned integer, which VB's Long can fill in for since a rating can't exceed 99 and be valid
Select Case lp
Case 1 To 12 'sys default when you assign values in Explorer=1
lp = 1
Case 13 To 37 'default=25
lp = 2
Case 38 To 62 'default=50
lp = 3
Case 63 To 87 'default=75
lp = 4
Case 88 To 99 'default=99
lp = 5
Case Else
lp = 0
End Select
GetFileRating = lp
Set isi = Nothing
Call ILFree(pidl) 'always release the memory used by pidls
End Function
Public Function SetFileRating(sFile As String, lNumberOfStars As Long) As Long
'Sets the star rating of a file. Should return 0 if things go ok.
Dim vvar As Variant
Dim lRating As Long
Dim isi As IShellItem2
Dim pidlFile As Long
Dim pps As IPropertyStore
Dim hr As Long
Dim pkRating As PROPERTYKEY '{64440492-4C8B-11D1-8B70-080036B11A03}, 9
DEFINE_PROPERTYKEY pkRating, &H64440492, CInt(&H4C8B), CInt(&H11D1), &H8B, &H70, &H8, &H0, &H36, &HB1, &H1A, &H3, 9
'The rating could technically be anything from 0 to 99; here I use the values that would be used if you set the rating in Explorer
Select Case lNumberOfStars
Case 1: lRating = 1
Case 2: lRating = 25
Case 3: lRating = 50
Case 4: lRating = 75
Case 5: lRating = 99
Case Else: lRating = 0
End Select
vvar = CVar(lRating) 'the property system will expect a PROPVARIANT, but in this case (not all cases), VariantToPropVariant isn't needed, we'll pass vvar directly
'We need the Property Store for the file, which we can get from its IShellItem
pidlFile = ILCreateFromPathW(StrPtr(sFile))
Call SHCreateItemFromIDList(pidlFile, IID_IShellItem2, isi)
isi.GetPropertyStore GPS_READWRITE, IID_IPropertyStore, pps 'we need write access- GPS_DEFAULT will not work
hr = pps.SetValue(pkRating, vvar) 'returns S_OK if successful
If hr = 0 Then
hr = pps.Commit 'save the changes; returns S_OK if successful
End If
Set pps = Nothing
Set isi = Nothing
Call ILFree(pidlFile) 'always set your pidl free!
SetFileRating = hr
End Function
Public Sub DEFINE_PROPERTYKEY(Name As PROPERTYKEY, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte, pid As Long)
With Name.fmtid
.Data1 = L
.Data2 = w1
.Data3 = w2
.Data4(0) = B0
.Data4(1) = b1
.Data4(2) = b2
.Data4(3) = B3
.Data4(4) = b4
.Data4(5) = b5
.Data4(6) = b6
.Data4(7) = b7
End With
Name.pid = pid
End Sub
If you're not using the mIID.bas from the oleexp thread, also include this:
Code:
Public Sub DEFINE_UUID(Name As UUID, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
With Name
.Data1 = L
.Data2 = w1
.Data3 = w2
.Data4(0) = B0
.Data4(1) = b1
.Data4(2) = b2
.Data4(3) = B3
.Data4(4) = b4
.Data4(5) = b5
.Data4(6) = b6
.Data4(7) = b7
End With
End Sub
Public Function IID_IShellItem2() As UUID
'7e9fb0d3-919f-4307-ab2e-9b1860310c93
Static iid As UUID
If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H7E9FB0D3, CInt(&H919F), CInt(&H4307), &HAB, &H2E, &H9B, &H18, &H60, &H31, &HC, &H93)
IID_IShellItem2 = iid
End Function
Public Function IID_IPropertyStore() As UUID
'DEFINE_GUID(IID_IPropertyStore,0x886d8eeb, 0x8cf2, 0x4446, 0x8d,0x02,0xcd,0xba,0x1d,0xbd,0xcf,0x99);
Static iid As UUID
If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H886D8EEB, CInt(&H8CF2), CInt(&H4446), &H8D, &H2, &HCD, &HBA, &H1D, &HBD, &HCF, &H99)
IID_IPropertyStore = iid
End Function
If you want to display these values in ListView of files, here's a good place to start.
