Excel VB - Shell object and Items extended properties

217 Views Asked by At

First of all i'm not a VB geek, but I've found my way through googling around and I just can't figure out this one...

Put simply, I made a macro that allows me to select pdfs, zip them, and build a list of those zipped files on another sheet, then automatically prepares an email with that zip as an attachment. I want that list to contain the following entries:

  • The file name without the path, and without the extension (done and code works, though I've read that I may have issues if "hide extension of know file type" is activated, not tested);
  • Then each file name is hyperlinked to the actual file location before being zipped (done and code works);
  • The document title, which is an extended property (title metadata) of the pdf (WITHOUT having Acrobat installed, done and code works);
  • The document Tags (or Keywords?), again extended property of the pdf. It's this one that I need help with!. I browsed through office documentations and just can't find the info I need.

Like I said, I'm not a coder, I know my code is not optimal so please don't judge me. I just want it to work, then I'll optimize it ;)

To get the title property I use the following code :

Sheet1.Range("F54").Value = oShell.Namespace("FOLDERPATH").Items.Item("FILE IN FOLDERPATH).ExtendedProperty("DocTitle")

"DocTitle" is the property name for the title. I just can't find what it is to extract "Tags", I've tried "Tags", "DocTags" and "Keywords" and I got nothing. I've tried using GetDetailsOf("FILE", 18), but it returns the string "Tags", not the actual tags...like... the title of the tags...

Here is the full code :

Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)

Sub ZipAndEmailFiles() 'By selecting individually
Dim CurDateTime         As String
Dim DefaultFilePath     As String
Dim FilesToZip          As String
Dim oShell:             Set oShell = CreateObject("Shell.Application")
Dim FileCount           As Long
Dim FileNumb            As Integer
Dim LastZipNumb         As Integer
Dim FileNames           As Variant
Dim VArr                As Variant
Dim ZipFileName         As Variant
Dim ProjectNumb         As String


LastZipNumb = Main.Range("C13").Value               'Get last qty of file(s) zipped
CurDateTime = Format(Now, "yyyy-mmm-dd h-mm-ss")    'Get actual date and time
DefaultFilePath = Application.DefaultFilePath
If Right(DefaultFilePath, 1) <> "\" Then DefaultFilePath = DefaultFilePath & "\"
ProjectNumb = Main.Range("C4").Value                'Get project number (Entry by user)

ZipFileName = DefaultFilePath & ProjectNumb & "-" & CurDateTime & ".zip" 'Name of zip

'Browse For Files & Select Multiple files
FileNames = Application.GetOpenFilename("PDF Files (*.pdf),*.pdf", MultiSelect:=True, Title:="Select Files you want to Zip & Email")

If IsArray(FileNames) = False Then Exit Sub

'Create Empty Zipped File in DefaultFilePath
If Len(Dir(ZipFileName)) > 0 Then Kill ZipFileName
Open ZipFileName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1

FileNumb = 0

'Clear cells from previous list
For FileCount = 1 To LastZipNumb
    FileNumb = FileNumb + 1
    ThisWorkbook.Worksheets("Transmittal").Range("B54:F54").Offset(2 * (FileNumb - 1), 0).Clear
Next

FileNumb = 0
   
'Build list & Fill zip
For FileCount = LBound(FileNames) To UBound(FileNames)
    FileNumb = FileNumb + 1
    'Insert name of each processed file, removing path, revision and extension
    Transmittal.Range("B54").Offset(2 * (FileNumb - 1), 0).Value = Left(GetFilenameFromPath(FileNames(FileNumb)), 12)
    'Create hyperlink to reference file being zipped
    ActiveSheet.Hyperlinks.Add Transmittal.Range("B54").Offset(2 * (FileNumb - 1), 0), FileNames(FileNumb)

    'Inscrire le titre dans la case indiquée
    'Transmittal.Range("F54").Offset(2 * (FileNumb - 1), 0).Value = oShell.Namespace(FolderFromPath(FileNames(FileNumb))).GetDetailsOf(FileNameFromPath(FileNames(FileNumb)), FileNumb)
    Transmittal.Range("D54").Offset(2 * (FileNumb - 1), 0).Value = oShell.Namespace(FolderFromPath(FileNames(FileNumb))).Items.Item(FileNameFromPath(FileNames(FileNumb))).ExtendedProperty("Keywords")
    Transmittal.Range("F54").Offset(2 * (FileNumb - 1), 0).Value = oShell.Namespace(FolderFromPath(FileNames(FileNumb))).Items.Item(FileNameFromPath(FileNames(FileNumb))).ExtendedProperty("DocTitle")
    'Copy said file in zip
    oShell.Namespace(ZipFileName).CopyHere FileNames(FileCount)
    
    'Keep Script waiting until compressing is done
    On Error Resume Next
    Do Until oShell.Namespace(ZipFileName).Items.Count = FileNumb
        Sleep (100) 'Wait 100ms after each copied file
    Loop
    On Error GoTo 0
Next FileCount
Main.Range("C22").Value = ZipFileName 'Place zip location, to be attached to email
Main.Range("C13").Value = UBound(FileNames)
EmailZipFile
End Sub

Sub EmailZipFile()
Dim OutApp As Object
Dim OutEmail As Object
Set OutApp = CreateObject("Outlook.application")
Set OutEmail = OutApp.CreateItem(0)
With OutEmail
    .To = Main.Range("C13").Value ' Email
    If Main.Range("C16").Value <> "" Then .Attachments.Add Main.Range("C16").Value 'Zipped file
    .Subject = Main.Range("C15").Value 'Email subject
    .Body = Main.Range("C17").Value 'Email body
    .Display 'Show Outlook windows
End With
End Sub

Function FileNameFromPath(ByVal strPath As String) As String
    FileNameFromPath = Right(strPath, Len(strPath) - InStrRev(strPath, "\"))
End Function

Function FolderFromPath(ByVal strPath As String) As String
    FolderFromPath = Left(strPath, InStrRev(strPath, "\"))
End Function

For the code to fully work, you have to have Outlook installed. But even without Outlook, the list generation works. Thanks for your help, and your time!

0

There are 0 best solutions below