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
pidl = ILCreateFromPathW(StrPtr(sFile))
Call SHCreateItemFromIDList(pidl, IID_IShellItem2, isi)
isi.GetUInt32 pkRating, lp
Select Case lp
Case 1 To 12 'sys default=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)
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
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)
pidlFile = ILCreateFromPathW(StrPtr(sFile))
Call SHCreateItemFromIDList(pidlFile, IID_IShellItem2, isi)
isi.GetPropertyStore GPS_READWRITE, IID_IPropertyStore, pps
hr = pps.SetValue(pkRating, vvar)
If hr = 0 Then
hr = pps.Commit
End If
Set pps = Nothing
Set isi = Nothing
Call ILFree(pidlFile)
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 SubCode:
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