using a Userform to change the document properties or tags

[dellehurley]

Hi
I have a userform which I use to move and rename files, populate an associated database and hopefully update the documents properties.
I have all the first parts working but I cannot get the documents properties sub to work. I feel like I have tried what feels thousands of variations.

Additional Info- all the files are jpg or pdfs. They are all moved and stored in the same folder which is where the excel database file is saved too. All the issues are in regards to objects not being declared.
the current error is runtime 91 -object variable or with block variable not set.

This is what I have so far

Dim fileName, folderName, newName As Variant
Dim NewNameObj As Image   'this was my most recent change
Dim EventDate As DocumentProperty
Dim Tags As DocumentProperty
Dim Description As DocumentProperty
Dim Evt, EvtDt, Tgs, Desc As String

folderName = ThisWorkbook.Path & "\"
fileName = frmNewEntry.txtFileName.Value
newName = folderName & fileName
'Set NewNameObj = newName.CustomDocumentProperties

Evt = frmNewEntry.cmbEvent.Value   'or ThisWorkbook.Sheets("Database").Range("D2").Value
Desc = frmNewEntry.txtDescription.Value  'or ThisWorkbook.Sheets("Database").Range("I2").Value
Tgs = ThisWorkbook.Sheets("Database").Range("J2").Value
EvtDt = frmNewEntry.txtDate.Value   'or ThisWorkbook.Sheets("Database").Range("H2").Value    'NB. I wish to keep this as a string even though it is a date as the info is not always a full date, it is often an estimate eg. Abt 1940
With NewNameObj.CustomDocumentProperties
    .Add Name:="nEvent", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=Evt   'BTW -Link to content Honestly I'm not sure what this is so it may be incorrect
    .Add Name:="Description", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=Desc   'Type names in an effort to try something else.
    .Add Name:="Tags", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=Tgs
    .Add Name:="EventDate", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=EvtDt

End With

I appreciate any help or suggestions.
Thanks
Dannielle

 

[Dan_W]

Ok, that's helpful. Thank you. I'm on 64bit, which makes a little tricky given that anything that works only on 32bit Office won't work 'out-of-the-box' for 64bit Office, and vice versa. The good news is that it's by no means insurmountable - I have located some routines/a library that allows us to set and read the EXIF metadata (in 32bit), but someone I know has made it compatible for both 32- and 64-bit. So I just need to check that it'll work for me too, and then it should be pretty straight-forward to implement. I'll have a look at it tonight, and report back tomorrow morning.

 

[Dan_W]

Hi. So Plan A didn't quite work out - the library I was hoping to use still has some bugs to work out. On the plus side (I'm always looking on the bright side of things!), Plan B might be even better. Plan B, however, assumes that you have the Windows Image Acquisition installed on your system - which, from what I understand, pretty much everyone with Windows these days does.

First, it would be helpful if we can check to make sure that this approach will work, so can you please try the Test_ReadProperties code with this sample photo. You will need to change the path to the file below. I have added EXIF metadata to image, the code I used for doing that is set out below in one of the test subroutines.

Please note that the WriteEXIFData will, by default, write over the image file you give it. I have built in an option for it not to do that, in which case it will return the new filename as a string. Also, it includes an option to add a backup. As you can probably tell, I'm super sensitive about ever deleting files with VBA. That being the case, please can you be sure to test this on dummy image files (like the one above) and make sure that you have backups of everything. The default assumption is the there is no undo available.

The functionality is a bit limited, but I just wanted to check to make sure it'll work. Do let me know if you're having any troubles with it. I have family visiting this weekend, but I should generally be around if you need help. Fingers crossed!

' WIA - EXIF MetaData - Reading and Writing Routines
' Author: Dan_W
' Example Usage:
'             WriteEXIFData Filename, PropertyName, PropertyValue, (Opt) WriteOverOriginal = True, (Opt) CreateBackup                                                                 
'              - WriteEXIFData "C:\Temp\IMG01 - Copy.jpg", ImageTitle, "New Image Title"               
'              - WriteEXIFData "C:\Temp\IMG01 - Copy.jpg", ImageTitle, "Live Life On The Edge", True                                                                                     
                                                                                                                                                                                            
'              - Comments = GetEXIFData("C:\Temp\IMG_20210508_170154.jpg", ImageComments)

    Public Enum PropertyNameEnum
        ImageDateTimeOriginal = 36867
        ImageTitle = 40091
        ImageComments = 40092
        ImageAuthor = 40093
        ImageKeywords = 40094
        ImageSubject = 40095
    End Enum
    
    Private Enum WIAImagePropertyType
        UndefinedImagePropertyType = 1000
        ByteImagePropertyType = 1001
        StringImagePropertyType = 1002
        UnsignedIntegerImagePropertyType = 1003
        LongImagePropertyType = 1004
        UnsignedLongImagePropertyType = 1005
        RationalImagePropertyType = 1006
        UnsignedRationalImagePropertyType = 1007
        VectorOfUndefinedImagePropertyType = 1100
        VectorOfBytesImagePropertyType = 1101
        VectorOfUnsignedIntegersImagePropertyType = 1102
        VectorOfLongsImagePropertyType = 1103
        VectorOfUnsignedLongsImagePropertyType = 1104
        VectorOfRationalsImagePropertyType = 1105
        VectorOfUnsignedRationalsImagePropertyType = 1106
    End Enum
    
    Const TargetFileName = "C:\Users\KJ\Downloads\pexels-jill-evans-11567527.jpg" '"C:\PathToFile\pexels-jill-evans-11567527.jpg"
    
    Sub Test_WriteProperties()
    
        Dim NewFileName As String
        NewFileName = WriteEXIFData(TargetFileName, ImageTitle, "White Concrete Building Under White Sky", True, True)
        WriteEXIFData NewFileName, ImageAuthor, "Jill Evans"
        WriteEXIFData NewFileName, ImageSubject, "Photo by Jill Evans from Pexels"
        WriteEXIFData NewFileName, ImageComments, "Source: https://www.pexels.com/photo/white-concrete-building-under-white-sky-11567527/"
        
        Debug.Print NewFileName
        
    End Sub
    
    Sub Test_ReadProperties()
        
        Dim Title As String
        Dim Subject As String
        Dim Comments As String
        Dim Author As String
        
        Title = GetEXIFData(TargetFileName, ImageTitle)
        Subject = GetEXIFData(TargetFileName, ImageSubject)
        Comments = GetEXIFData(TargetFileName, ImageComments)
        Author = GetEXIFData(TargetFileName, ImageAuthor)
        
        MsgBox "Title: " & Title & vbNewLine & _
               "Author: " & Author & vbNewLine & _
               "Subject: " & Subject & vbNewLine & _
               "Comments: " & Comments
    End Sub
    
    Public Function GetEXIFData(Filename As String, PropertyName As PropertyNameEnum) As String
    
        Dim Image               As Object
        Dim ImageProperty       As Object
        Dim Result              As String
        
        Set Image = CreateObject("WIA.ImageFile")
        Image.LoadFile Filename
    
        For Each ImageProperty In Image.Properties
            If ImageProperty.PropertyID = PropertyName Then
                If TypeName(ImageProperty.Value) = "String" Then
                    Result = ImageProperty.Value
                Else
                    Result = Replace(StrConv(ImageProperty.Value.BinaryData, vbUnicode), Chr(0), "")
                End If
                Exit For
            End If
        Next
        
        GetEXIFData = Result
    
    End Function
    
    Public Function WriteEXIFData(ByVal Filename As String, ByVal PropertyName As PropertyNameEnum, ByVal PropertyValue As Variant, Optional ByVal OverWriteOriginal As Boolean = True, Optional ByVal CreateBackup As Boolean)
    
        Dim Image               As Object
        Dim ImageProcess        As Object
        Dim ImageVector         As Object
        Dim NewFileName         As String
        
        If CreateBackup = True Then
            Dim BackUpFilename  As String
            BackUpFilename = Replace(Filename, ".jpg", "_BACKUP(" & Format(Now, "ddmmyyyy-hhnn") & ").jpg")
            FileCopy Filename, BackUpFilename
        End If
        
        Set Image = CreateObject("WIA.ImageFile")
        Set ImageProcess = CreateObject("WIA.ImageProcess")
        Set ImageVector = CreateObject("WIA.Vector")
        
        Image.LoadFile Filename
        
        ImageProcess.Filters.Add ImageProcess.FilterInfos("Exif").FilterID
        ImageProcess.Filters(1).Properties("ID") = PropertyName
        
        Select Case PropertyName
            
            Case PropertyNameEnum.ImageDateTimeOriginal
                Dim StringValue As String
                StringValue = Format(PropertyValue, "YYYY:MM:DD HH:MM:SS")
                ImageProcess.Filters(1).Properties("Type") = StringImagePropertyType
                ImageProcess.Filters(1).Properties("Value") = StringValue
            
            Case Else
                ImageProcess.Filters(1).Properties("Type") = VectorOfBytesImagePropertyType
                ImageVector.SetFromString PropertyValue
                ImageProcess.Filters(1).Properties("Value") = ImageVector
        
        End Select
        
        Set Image = ImageProcess.Apply(Image)
        
        If OverWriteOriginal = True Then
            NewFileName = Filename
            Kill Filename
        Else
            NewFileName = Replace(Filename, ".jpg", "_metadata.jpg")
            If Len(Dir(NewFileName)) > 0 Then Kill NewFileName
        End If
        
        Image.SaveFile NewFileName
    
        WriteEXIFData = NewFileName
    
    End Function

 

[dellehurley]

Hi. So Plan A didn't quite work out - the library I was hoping to use still has some bugs to work out. On the plus side (I'm always looking on the bright side of things!), Plan B might be even better. Plan B, however, assumes that you have the Windows Image Acquisition installed on your system - which, from what I understand, pretty much everyone with Windows these days does.

First, it would be helpful if we can check to make sure that this approach will work, so can you please try the Test_ReadProperties code with this sample photo. You will need to change the path to the file below. I have added EXIF metadata to image, the code I used for doing that is set out below in one of the test subroutines.

Please note that the WriteEXIFData will, by default, write over the image file you give it. I have built in an option for it not to do that, in which case it will return the new filename as a string. Also, it includes an option to add a backup. As you can probably tell, I'm super sensitive about ever deleting files with VBA. That being the case, please can you be sure to test this on dummy image files (like the one above) and make sure that you have backups of everything. The default assumption is the there is no undo available.

The functionality is a bit limited, but I just wanted to check to make sure it'll work. Do let me know if you're having any troubles with it. I have family visiting this weekend, but I should generally be around if you need help. Fingers crossed!

' WIA - EXIF MetaData - Reading and Writing Routines
' Author: Dan_W
' Example Usage:
'             WriteEXIFData Filename, PropertyName, PropertyValue, (Opt) WriteOverOriginal = True, (Opt) CreateBackup                                                                
'              - WriteEXIFData "C:\Temp\IMG01 - Copy.jpg", ImageTitle, "New Image Title"              
'              - WriteEXIFData "C:\Temp\IMG01 - Copy.jpg", ImageTitle, "Live Life On The Edge", True                                                                                    
                                                                                                                                                                                           
'              - Comments = GetEXIFData("C:\Temp\IMG_20210508_170154.jpg", ImageComments)

    Public Enum PropertyNameEnum
        ImageDateTimeOriginal = 36867
        ImageTitle = 40091
        ImageComments = 40092
        ImageAuthor = 40093
        ImageKeywords = 40094
        ImageSubject = 40095
    End Enum
   
    Private Enum WIAImagePropertyType
        UndefinedImagePropertyType = 1000
        ByteImagePropertyType = 1001
        StringImagePropertyType = 1002
        UnsignedIntegerImagePropertyType = 1003
        LongImagePropertyType = 1004
        UnsignedLongImagePropertyType = 1005
        RationalImagePropertyType = 1006
        UnsignedRationalImagePropertyType = 1007
        VectorOfUndefinedImagePropertyType = 1100
        VectorOfBytesImagePropertyType = 1101
        VectorOfUnsignedIntegersImagePropertyType = 1102
        VectorOfLongsImagePropertyType = 1103
        VectorOfUnsignedLongsImagePropertyType = 1104
        VectorOfRationalsImagePropertyType = 1105
        VectorOfUnsignedRationalsImagePropertyType = 1106
    End Enum
   
    Const TargetFileName = "C:\Users\KJ\Downloads\pexels-jill-evans-11567527.jpg" '"C:\PathToFile\pexels-jill-evans-11567527.jpg"
   
    Sub Test_WriteProperties()
   
        Dim NewFileName As String
        NewFileName = WriteEXIFData(TargetFileName, ImageTitle, "White Concrete Building Under White Sky", True, True)
        WriteEXIFData NewFileName, ImageAuthor, "Jill Evans"
        WriteEXIFData NewFileName, ImageSubject, "Photo by Jill Evans from Pexels"
        WriteEXIFData NewFileName, ImageComments, "Source: https://www.pexels.com/photo/white-concrete-building-under-white-sky-11567527/"
       
        Debug.Print NewFileName
       
    End Sub
   
    Sub Test_ReadProperties()
       
        Dim Title As String
        Dim Subject As String
        Dim Comments As String
        Dim Author As String
       
        Title = GetEXIFData(TargetFileName, ImageTitle)
        Subject = GetEXIFData(TargetFileName, ImageSubject)
        Comments = GetEXIFData(TargetFileName, ImageComments)
        Author = GetEXIFData(TargetFileName, ImageAuthor)
       
        MsgBox "Title: " & Title & vbNewLine & _
               "Author: " & Author & vbNewLine & _
               "Subject: " & Subject & vbNewLine & _
               "Comments: " & Comments
    End Sub
   
    Public Function GetEXIFData(Filename As String, PropertyName As PropertyNameEnum) As String
   
        Dim Image               As Object
        Dim ImageProperty       As Object
        Dim Result              As String
       
        Set Image = CreateObject("WIA.ImageFile")
        Image.LoadFile Filename
   
        For Each ImageProperty In Image.Properties
            If ImageProperty.PropertyID = PropertyName Then
                If TypeName(ImageProperty.Value) = "String" Then
                    Result = ImageProperty.Value
                Else
                    Result = Replace(StrConv(ImageProperty.Value.BinaryData, vbUnicode), Chr(0), "")
                End If
                Exit For
            End If
        Next
       
        GetEXIFData = Result
   
    End Function
   
    Public Function WriteEXIFData(ByVal Filename As String, ByVal PropertyName As PropertyNameEnum, ByVal PropertyValue As Variant, Optional ByVal OverWriteOriginal As Boolean = True, Optional ByVal CreateBackup As Boolean)
   
        Dim Image               As Object
        Dim ImageProcess        As Object
        Dim ImageVector         As Object
        Dim NewFileName         As String
       
        If CreateBackup = True Then
            Dim BackUpFilename  As String
            BackUpFilename = Replace(Filename, ".jpg", "_BACKUP(" & Format(Now, "ddmmyyyy-hhnn") & ").jpg")
            FileCopy Filename, BackUpFilename
        End If
       
        Set Image = CreateObject("WIA.ImageFile")
        Set ImageProcess = CreateObject("WIA.ImageProcess")
        Set ImageVector = CreateObject("WIA.Vector")
       
        Image.LoadFile Filename
       
        ImageProcess.Filters.Add ImageProcess.FilterInfos("Exif").FilterID
        ImageProcess.Filters(1).Properties("ID") = PropertyName
       
        Select Case PropertyName
           
            Case PropertyNameEnum.ImageDateTimeOriginal
                Dim StringValue As String
                StringValue = Format(PropertyValue, "YYYY:MM:DD HH:MM:SS")
                ImageProcess.Filters(1).Properties("Type") = StringImagePropertyType
                ImageProcess.Filters(1).Properties("Value") = StringValue
           
            Case Else
                ImageProcess.Filters(1).Properties("Type") = VectorOfBytesImagePropertyType
                ImageVector.SetFromString PropertyValue
                ImageProcess.Filters(1).Properties("Value") = ImageVector
       
        End Select
       
        Set Image = ImageProcess.Apply(Image)
       
        If OverWriteOriginal = True Then
            NewFileName = Filename
            Kill Filename
        Else
            NewFileName = Replace(Filename, ".jpg", "_metadata.jpg")
            If Len(Dir(NewFileName)) > 0 Then Kill NewFileName
        End If
       
        Image.SaveFile NewFileName
   
        WriteEXIFData = NewFileName
   
    End Function

Oops my turn to miss an update. Sorry I only saw this today.
No I probably demonstrate my stupidity but I'm not sure how to proceed. I saved your macros in a new module and called the first one Sub DanTagging as there was no sub name at the top (and it did not work without a name either) and left the rest as is, except for the file path. If I run it from there I get an error "User Defined type not defined" so I presume that was not correct. Should I call it as a part of my saving process or something else?
I hope your weekend is enjoyable.
Dannielle

 

[Dan_W]

Oops my turn to miss an update. Sorry I only saw this today.
No I probably demonstrate my stupidity but I'm not sure how to proceed. I saved your macros in a new module and called the first one Sub DanTagging as there was no sub name at the top (and it did not work without a name either) and left the rest as is, except for the file path. If I run it from there I get an error "User Defined type not defined" so I presume that was not correct. Should I call it as a part of my saving process or something else?
I hope your weekend is enjoyable.
Dannielle

Ah, sorry, I failed to explain the key step in the process - what does one do with the code?!? That's a very fair point. The code is intended just to be copied and pasted as-is into a standard module. It doesn't need a sub name - the subs and functions start halfway down the code block. These Enum constructs are just there to make it easier for you to call the functions. For now, it would just be useful to just to make sure that the method works. So to recap, please:
1. Insert a new module (you can get rid of the last one)
2. Copy and paste the code above into the module
3. Change the file path to where the downloaded image is.
4. Run the Test_ReadProperties subroutine.
If that works, we're in luck!

 

[Dan_W]

Hi Dannielle - any luck with the code?

 

[dellehurley]

Hi Dannielle - any luck with the code?

Hi Dan, Sorry I have been away from my computer, life got in the way. That worked perfectly.
Dannielle

 

[dellehurley]

Hi Dan, Sorry I have been away from my computer, life got in the way. That worked perfectly.
Dannielle

Hi Dannielle - any luck with the code?

Hi Dan,
I have finally had time to really look at your code. I have tried it on different files and changes the author, comments etc to variable and it is working perfectly. One fluid step when a file is saved to the database. I could not do this without your help. Thank you very much.
Dannielle