我正在尝试构建一个基于Excel-VBA的工具，我需要捕获和编辑存储在硬盘上的图像（.jpg）文件的文件属性，包括一些扩展属性（特别是注释属性）。
我能够获取代码来遍历文件并捕获扩展属性，如作者，关键字，评论等以及右键单击文件时可见的其他属性。
我现在正在尝试编写/编辑这些属性，但我无法找到任何方法。如果你可以帮助解决VBA的确切代码片段，那将会很棒。
我用来阅读这些属性的代码如下（来自Alex K）
Using VBA to get extended file attributes
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace("c:\foo")
For Each sFile In oDir.Items
Debug.Print oDir.GetDetailsOf(sFile, 24) '24 - index corresponding to comments
Next
答案 0 :(得分：0)
' a bit of a play with classes works OK
'Harry S
'you need a work sheet with a command button
'and some properties listed on a row
'
' a standard module
'
' three class modules named node , shelBtree, shelprop
' in the worksheet module
'
Option Explicit: Option Compare Text
'problem
' shell does not have nice CallByName VBGet of VBLet as in
' Thisp = CallByName(DSO.SummaryProperties, Ars(Dp + 1), VbGet)
' CallByName DSO.SummaryProperties, ass(2), VbLet, Thisp & ";" & Ars(Dp + 2)
'
' however it will replace the datemodified
' about the only let or write property that I can work in namespace in VBA
'
Private Sub CommandButton2_Click()
TreeGrown = False '
' store names and index in binary tree for fast searching
' use a collection or a dictionary but tree is fast
'and can also be used as unique value sort
GrowShellTree
'
' demo listing comment out
pShelT.EnumThem
'
ShelOut "p:\testbad", Range("f6:AJ6")
' folder for files, range where you have a row of the properties that you want listed
'like .. Name Size Rating tags Authors Title Subject Folder name Folder path Folder Participants Path
' should list down columns F .. AJ whatever properties for the files in the folder p:\testbad
End Sub
' in a standard module
Public pShelT As ShelBTree, TreeGrown As Boolean, WSP As ShelProp
Sub GrowShellTree()
If Not TreeGrown Then
Dim ObjShell, ObjFolder, li%, ws$
Set pShelT = Nothing
Set pShelT = New ShelBTree
Set ObjShell = CreateObject("Shell.Application")
Set ObjFolder = ObjShell.Namespace("C:\") ' any folder will do
For li = 0 To 290 ' about 285
ws$ = ObjFolder.GetDetailsOf(ObjFolder.Items, li)
If ws <> "" Then
Set WSP = New ShelProp
WSP.id = li
WSP.Name = ws
pShelT.Insert WSP
End If
Cells(li + 3, 3) = li
Cells(li + 3, 4) = ws
Next li
TreeGrown = True
End If
End Sub
Sub ShelOut(FoldN, RaP As Range)
' FoldN works OK but FoldN$ is not a variant
Dim ObjShell, ObjFolder, li%, IDx%, ws$, Fname, ro%
GrowShellTree
Set ObjShell = CreateObject("Shell.Application")
Set ObjFolder = ObjShell.Namespace(FoldN)
For Each Fname In ObjFolder.Items
ro = ro + 1
For li = 1 To RaP.Columns.Count
IDx = pShelT.FindId(RaP(1, li))
If IDx >= 0 And IDx < 290 Then
RaP(ro + 2, li) = ObjFolder.GetDetailsOf(Fname, IDx)
End If
Next li
Next Fname
ActiveSheet.Columns.AutoFit
End Sub
'
'in ShelBtree class module
'
Option Explicit: Option Compare Text
'
' a poor programmers fast dictionary
'
Private wShelProp As ShelProp, Fname$, Wid%
Private Parent As Node, NewNode As Node, Outi%
'Private m_List As ListBox
Public Sub Insert(x As ShelProp)
Set NewNode = New Node ' makes Left & Right nothing
Set NewNode.fb = x
Set wShelProp = x
If Parent Is Nothing Then
Set Parent = NewNode
Else
PutTheNode Parent
End If
End Sub
Private Sub PutTheNode(AtNode As Node)
If wShelProp.Name > AtNode.fb.Name Then
If Not (AtNode.Right Is Nothing) Then
PutTheNode AtNode.Right
Else
Set AtNode.Right = NewNode
End If
End If
' use else if you want to add if =
If wShelProp.Name < AtNode.fb.Name Then
If Not (AtNode.Left Is Nothing) Then
PutTheNode AtNode.Left
Else
Set AtNode.Left = NewNode
End If
End If
End Sub
Private Sub Findat(AtNode As Node)
If AtNode.fb.Name = Fname Then
Wid = AtNode.fb.id
Else
If AtNode.fb.Name < Fname Then
If Not (AtNode.Right Is Nothing) Then
Findat AtNode.Right
Else
Wid = -2
End If
End If
If AtNode.fb.Name > Fname Then
If Not (AtNode.Left Is Nothing) Then
Findat AtNode.Left
Else
Wid = -3
End If
End If
End If
End Sub
Public Function FindId%(Nam$)
Fname = Nam: Wid = 0
If Fname = "Name" Then
FindId = 0
Else
If Not Parent Is Nothing Then
Findat Parent
FindId = Wid
Else
FindId = -1 ' as no tree
End If
End If
End Function
Public Sub EnumThem()
Outi = 0
If Not Parent Is Nothing Then
Outi = 2
RecEnum Parent
Else
MsgBox "Parent is nothing"
End If
End Sub
Private Sub RecEnum(AtNode As Node)
If Not (AtNode.Left Is Nothing) Then RecEnum AtNode.Left
Outi = Outi + 1
'
' two lines only for demo
Cells(Outi, 1) = AtNode.fb.Name
Cells(Outi, 2) = AtNode.fb.id
'
If Not (AtNode.Right Is Nothing) Then RecEnum AtNode.Right
End Sub
Public Sub DeleteAll()
If Not Parent Is Nothing Then RecursiveDelete Parent
End Sub
'While deleting, first delete left then right then head
Private Sub RecursiveDelete(AtNode As Node)
If Not (AtNode.Left Is Nothing) Then RecursiveDelete AtNode.Left
If Not (AtNode.Right Is Nothing) Then RecursiveDelete AtNode.Right
Set AtNode = Nothing
End Sub
'
'
'in Node class module
' not a big class but it does some very good work
'
Option Explicit
Public fb As ShelProp, Left As Node, Right As Node
'
' in ShelProp class module
'
Option Explicit: Option Compare Text
Private PName$, Pid%
Public Property Get id%()
id = Pid
End Property
Public Property Let id(v%)
Pid = v
End Property
Public Property Let Name(v$)
PName = v
End Property
Public Property Get Name$()
Name = PName
End Property