Posts by Kenneth Hobson

Sub CSVExiftool()
  Dim pathExiftool As String, s As String, wsh As Object, testFile As String
  Dim sOut As String, a, c, d, i As Integer
  
  'Path to a file to get its properties/metadata
  testFile = "d:\myfiles\exiftool\ken.pdf"
  
  'https://exiftool.org/
  'Install the tool and set path below. Copy exiftool(-k).exe to exiftool.exe.
  pathExiftool = "D:\MyFiles\exiftool\exiftool.exe"
  
  'Set the string to execute exiftool with command line switches
  's= """" & pathExiftool & """" & " -all " & """" & testFile & """"
  s = """" & pathExiftool & """" & " -csv " & """" & testFile & """"
  
  'Exit if pathExiftool does not exist.
  If Dir(pathExiftool) = "" Then
    MsgBox pathExiftool, vbExclamation, "Path Does Not Exist - Macro Ending"
    Exit Sub
  End If
  
  'Exit if testFile does not exist.
  If Dir(testFile) = "" Then
    MsgBox testFile, vbExclamation, "Path Does Not Exist - Macro Ending"
    Exit Sub
  End If
    
  Set wsh = CreateObject("WScript.Shell")
  sOut = wsh.Exec(s).StdOut.ReadAll
  Set wsh = Nothing
  
  'Split output into an array
  a = Split(sOut, vbLf) '2 rows
  c = Split(a(0), ",")  'fields
  d = Split(a(1), ",") 'values
  ReDim a(1 To 2, 1 To UBound(c) + 1)
  For i = 1 To UBound(c) + 1
    a(1, i) = c(i - 1)
    a(2, i) = d(i - 1)
  Next i
  
  'Put array into range
  Range("A1").Resize(2, UBound(c) + 1) = a
  ActiveSheet.UsedRange.EntireColumn.AutoFit
End Sub

'https://exiftool.org/forum/index.php?topic=3943.15

'This code is VBA code designed to accept filenames from the user (via a pop-up
'File-Dialog where user can select multiple files at the one time. The code then
'processes each file, removing the metadata in the file then saving the file back
'out into either the original file of (optionally) a new file with extension
'".nometa.pdf"
'
'Note! At the moment this code is deigned to work with PDF files and would require
'      changes to be made in the code to accomodate non-PDF files.
'
'Note!:
'This module must have the following references included
'within the VBA Editor environment
'  Visual Basic for Applications
'  Microsoft Access 11.o Object Library  (or equivalent/later)
'  Microsoft Office 14.0 Object Library  (or equivalent/later)
'  Adobe Acrobat 5.0 Type Library        (or equivalent/later)
'Include these by clicking on "Tools/References" within the editor

Public Sub RemoveMetaFromFiles()
Dim AcroPDDoc As Acrobat.CAcroPDDoc
Dim bOverwriteOriginal As Boolean
Dim cExt As String
Dim cFile As String
Dim cFiles As String
Dim cMsg As String
Dim cRoot As String
Dim fs As Object
Dim nEndSize As Long
Dim nFile As Integer
Dim nFiles As Long
Dim nStartSize As Long
Dim oDlg As FileDialog
Dim oFile As Object

'Change the following line to have value "True" if you DO
'want to overwrite the original file rather than writing to a new
'file with extension ".nometa.pdf"
bOverwriteOriginal = False

Set AcroPDDoc = CreateObject("AcroExch.PDDoc")

Set oDlg = Application.FileDialog(msoFileDialogFilePicker)
oDlg.InitialFileName = "*.pdf"
oDlg.AllowMultiSelect = True
oDlg.ButtonName = "Select"
oDlg.Title = "Select files from which MetaData is to be extracted:"
oDlg.Filters.Add "PDF Files", "*.pdf", 1
oDlg.Filters.Add "All Files", "*.*", 2
oDlg.InitialView = msoFileDialogViewDetails
Set fs = CreateObject("Scripting.FileSystemObject")
oDlg.InitialFileName = GetSetting(Application.Name, "Setup", "InitialFileName", "*.pdf")
If oDlg.Show = -1 Then
  cMsg = "MetaData removed:" + vbCrLf + vbCrLf
  nFiles = oDlg.SelectedItems.Count
  For nFile = 1 To nFiles
    SaveSetting Application.Name, "Setup", "InitialFileName", oDlg.InitialFileName
    Application.StatusBar = "Removing Metadata: " + CStr(nFile) + "/" + cFiles + ":" + cFile
    cFile = oDlg.SelectedItems(nFile)
    If fs.FileExists(cFile) Then
      Set oFile = fs.getfile(cFile)
      nStartSize = nStartSize + oFile.Size
      cMsg = cMsg + Space(4) + Format(nStartSize, "###,###,###")
      cExt = LCase(Mid(cFile, InStrRev(cFile, ".")))
      cRoot = Replace(cFile, cExt, "")
     
      StripMeta cFile, cExt, bOverwriteOriginal
     
      nEndSize = nEndSize + oFile.Size
      Select Case cExt
        Case ".pdf"
          'Open the newly stripped PDF file
          If AcroPDDoc.Open(cRoot + ".nometa.pdf") Then
            'then  save it removing unreferenced objects
            AcroPDDoc.Save PDSaveCollectGarbage + PDSaveFull, cRoot + ".nometa.pdf"
            AcroPDDoc.Close
          End If
      End Select
      cMsg = cMsg + " => " + Format(nEndSize, "###,###,###") + ": " + cRoot + ".nometa.pdf" + vbCrLf
    End If
  Next
  Application.StatusBar = ""
  Set AcroPDDoc = Nothing
  MsgBox cMsg, vbInformation + vbOKOnly
End If
End Sub
'
'

Private Sub StripMeta(cFile As String, cExt As String, bOverwriteOriginal As Boolean)
   Dim cExitTool As String
   Dim cOutFile As String
   Dim cExifTool As String
   
   'Note!: Comment out/amend the following to point to the exifTool Utility on your system
   cExifTool = "D:\myfiles\exiftool\exiftool.exe"
   'cExifTool = "c:\Program Files\exifTool\exiftool.exe"
   
   Select Case cExt
     Case ".pdf"
       'The following lines remove the Metadata from the document dictionary only
       If bOverwriteOriginal Then
          Shell cExifTool + " -all= " + cFile, vbMinimizedFocus
       Else
          cOutFile = Replace(cFile, cExt, "") + ".nometa.pdf"
          Shell cExifTool + " -all= -o " + cOutFile + " " + cFile, vbMinimizedFocus
       End If
   End Select
End Sub

Sub Test_ReadPDFMetaData()
  ReadPDFMetaData "d:\myfiles\pdf\A10_1.pdf"
End Sub

'Acrobat metadata late binding example, http://vbcity.com/forums/t/170532.aspx
'Early binding method:
Sub ReadPDFMetaData(ByVal sFile As String)
  'Dim oApp As Object 'late binding
  'Dim odoc As Object 'late binding
  'Tools > References > Acrobat
  Dim oApp As AcroApp 'early binding
  Dim odoc As AcroPDDoc 'early binding
  Dim d As Long
  
  Dim strFileName As String, strNumPages As Long, strPageMode As String
  Dim strTitle As String, strSubject As String, strAuthor As String
  Dim strKeywords As String, strCreator As String, strProducer As String
  
  'Set oApp = CreateObject("AcroExch.App")  'Early or late binding
  'Set odoc = CreateObject("AcroExch.PDDoc")  'Early or late binding
  Set oApp = New AcroApp 'Early binding
  Set odoc = New AcroPDDoc 'Early binding
  
  With odoc
    .Open sFile
    strFileName = .GetFileName
    Debug.Print strFileName
    strNumPages = .GetNumPages
    Debug.Print strNumPages
    strPageMode = .GetPageMode
    Debug.Print strPageMode
    strTitle = .GetInfo("Title")
    Debug.Print strTitle
    strSubject = .GetInfo("Subject")
    Debug.Print strSubject
    strAuthor = .GetInfo("Author")
    Debug.Print strAuthor
    strKeywords = .GetInfo("Keywords")
    Debug.Print strKeywords
    strCreator = .GetInfo("Creator")
    Debug.Print strCreator
    strProducer = .GetInfo("Producer")
    Debug.Print strProducer
    .Close
  End With
    
  Set odoc = Nothing
  Set oApp = Nothing
End Sub

Sub FileProperties()
  Dim pPDF As String, pdfWild As String, rNames As Range
  Dim oPropN, oPropV, aProp, e
  Dim fso As Object, oFolder As Object, oFile As Object
  Dim rFile As Range, rn As Long, cn As Integer
  
  '***************************************** INPUTS *****************************
  'Path to PDF folder, assumed to exist. Could be any folder or type of file.
  'pPDF = "d:\myfiles\pdf\"  'Must include trailing backslash character.
  pPDF = "c:\myfiles\pdf\"  'Must include trailing backslash character.
  
  'Wildcard files by file extension.
  pdfWild = "*.pdf" '*.* for all files, *.xlsx, *.docx, etc.
  
  'First cell to for property names list to right as column headings
  Set rNames = Range("B1")
  '**************************************** END INPUTS ************************
  Set rFile = rNames.Offset(1, -1) 'First file is left and down from cell with first property name
  
  If Dir(pPDF, vbDirectory) = "" Then Exit Sub
    
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set oFolder = fso.GetFolder(pPDF)
  If oFolder.Files.Count = 0 Then GoTo EndNow
  
  rNames.Offset(, -1) = "Files"
  'Get the property names only
  Set oPropN = oPropertyNames(pPDF & Dir(pPDF & pdfWild)) 'Must be at least one pdf/file
  rNames.Resize(, oPropN.Count + 1) = oPropN.toarray()
  
  'Size Array big enough for all files in the folder and their Property Values
  ReDim aProp(1 To oFolder.Files.Count, 1 To oPropN.Count)
  
  'Add hyperlink to files in column left of rNames and Build Array of Property Values
  For Each oFile In oFolder.Files
    If Not oFile.Name Like pdfWild Then GoTo nextoFile
    
    'Add hyperlink to the each pdfWild file
    rFile.Hyperlinks.Add rFile, oFile.Path, , , fso.GetBaseName(oFile.Name)
    Set rFile = rFile.Offset(1)
    
    'Get the property values only
    Set oPropV = oAllPropertyValues(oFile.Path)

    'Add property values to array
    rn = rn + 1
    For cn = 1 To oPropV.Count
      aProp(rn, cn) = oPropV(cn - 1)
    Next cn
    
nextoFile:
  Next oFile
  Set oFile = Nothing
  
  'Insert array of property values
  rNames.Offset(1).Resize(rn, oPropV.Count) = aProp
  
  ActiveSheet.UsedRange.EntireColumn.AutoFit
   
EndNow:
  Set oFolder = Nothing
  Set fso = Nothing
  Set oPropN = Nothing
  Set oPropV = Nothing
  
  MsgBox "File properties have been added. " & vbLf & pPDF & pdfWild, vbInformation, "File Property/Meta Data"
End Sub

Function oPropertyNames(PathFile As String)
  Dim i As Integer, sProp
  Dim sFolder, sFile '<-Both must be type Variant
  Dim oList As Object
  
  If Dir(PathFile) = "" Then Exit Function
  'https://docs.microsoft.com/en-us/dotnet/api/system.collections.arraylist?view=net-5.0
  Set oList = CreateObject("System.Collections.ArrayList")
  sFolder = Left(PathFile, InStrRev(PathFile, "\"))
  sFile = Right(PathFile, Len(PathFile) - Len(sFolder))
  
  With CreateObject("Shell.Application").Namespace(sFolder)
    For i = 0 To 350  'appears to be 322 names in Windows 10
      'https://docs.microsoft.com/en-us/windows/win32/shell/folder-getdetailsof
      'sProp = .GetDetailsOf(.Items.Item(sFile), i) 'Property Value
      'sProp = .GetDetailsOf(.Items.Item(""), i) 'Property Name
      sProp = .GetDetailsOf(.Items, i) 'Property Name
      oList.Add sProp
      'Debug.Print i, sProp, .GetDetailsOf(.Items.Item(sFile), i)
    Next i
    
    'Remove empty names from bottom up to first with property name
    For i = 350 To 0 Step -1
      If oList(i) = "" Then
        oList.removeat (i)
        Else
        Exit For
      End If
    Next i
  End With

  Set oPropertyNames = oList
End Function
'snb, extensive GetDetailsOf and parsing examples, https://www.snb-vba.eu/VBA_Bestanden_en.html


Function oAllPropertyValues(PathFile As String)
  Dim i As Integer, sProp
  Dim sFolder, sFile '<-Both must be type Variant
  Dim oList As Object
  
  If Dir(PathFile) = "" Then Exit Function
  'https://docs.microsoft.com/en-us/dotnet/api/system.collections.arraylist?view=net-5.0
  Set oList = CreateObject("System.Collections.ArrayList")
  sFolder = Left(PathFile, InStrRev(PathFile, "\"))
  sFile = Right(PathFile, Len(PathFile) - Len(sFolder))
  
  With CreateObject("Shell.Application").Namespace(sFolder)
    For i = 0 To 350  'appears to be 322 names in Windows 10
      'https://docs.microsoft.com/en-us/windows/win32/shell/folder-getdetailsof
      sProp = .GetDetailsOf(.Items.Item(sFile), i) 'Property Value
      oList.Add sProp
    Next i
    
    'Remove empty Values from bottom up to first with property value
    For i = 350 To 0 Step -1
      If oList(i) = "" Then
        oList.removeat (i)
        Else
        Exit For
      End If
    Next i
  End With

  'aPropertyNames = oList.toarray()
  Set oAllPropertyValues = oList
End Function

Sub FileProperties()
  Dim pPDF As String, aProp
  Dim fso As Object, oFolder As Object, oFile As Object
  Dim rNames As Range

  'Path to PDF folder, assumed to exist
  pPDF = "d:\myfiles\pdf\"
  'First cell for property names list to right as column headings
  Set rNames = Range("B1")
  
  If Dir(pPDF, vbDirectory) = "" Then Exit Sub
    
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set oFolder = fso.GetFolder(pPDF)
  If oFolder.Files.Count = 0 Then GoTo EndNow
 
  'Get the property names only
  Set aProp = oPropertyNames(pPDF & Dir(pPDF & "*.pdf")) 'Must be at least one pdf
  'MsgBox Join(aProp.toarray(), vbCrLf)
  rNames.Resize(, aProp.Count + 1) = aProp.toarray()
  
  
  'Iterative parts for later to process files in folder pPDF
  For Each oFile In oFolder.Files
    'Debug.Print oFile.Name, oFile.Path
  Next oFile
  Set oFile = Nothing
  
  ActiveSheet.UsedRange.EntireColumn.AutoFit
   
EndNow:
  Set oFolder = Nothing
  Set fso = Nothing
  Set aProp = Nothing
End Sub

Function oPropertyNames(PathFile As String)
  Dim i As Integer, sProp
  Dim sFolder, sFile '<-Both must be type Variant
  Dim oList As Object
  
  If Dir(PathFile) = "" Then Exit Function
  'https://docs.microsoft.com/en-us/dotnet/api/system.collections.arraylist?view=net-5.0
  Set oList = CreateObject("System.Collections.ArrayList")
  sFolder = Left(PathFile, InStrRev(PathFile, "\"))
  sFile = Right(PathFile, Len(PathFile) - Len(sFolder))
  
  With CreateObject("Shell.Application").Namespace(sFolder)
    For i = 0 To 350  'appears to be 322 names in Windows 10
      'https://docs.microsoft.com/en-us/windows/win32/shell/folder-getdetailsof
      'sProp = .GetDetailsOf(.Items.Item(sFile), i) 'Property Value
      'sProp = .GetDetailsOf(.Items.Item(""), i) 'Property Name
      sProp = .GetDetailsOf(.Items, i) 'Property Name
      oList.Add sProp
      'Debug.Print i, sProp, .GetDetailsOf(.Items.Item(sFile), i)
    Next i
    
    'Remove empty names from bottom up to first with property name
    For i = 350 To 0 Step -1
      If oList(i) = "" Then
        oList.removeat (i)
        Else
        Exit For
      End If
    Next i
  End With
  'Debug.Print oList.Count '321 which is 322 names for Windows 10
  
  'Debug.Print oList(5), oList.IndexOf("Date accessed", 0), oList.IndexOf("Date", 0), oList.Count
  'aPropertyNames = oList.toarray()
  Set oPropertyNames = oList
End Function
'snb, extensive GetDetailsOf and parsing examples, https://www.snb-vba.eu/VBA_Bestanden_en.html

'http://www.vbaexpress.com/forum/showthread.php?57202-objFolder-GetDetailsOf-not-working
Sub Test_FileProperty()
  MsgBox FileProperty("C:\Users\ken\Dropbox\", "Getting Started.pdf", "Name"), , "Name"
End Sub

Function FileProperty(FilePath As String, FileName As String, PropName As String) As String
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object
    Dim i As Long
     
    FileProperty = vbNullString
    i = FieldNumber(PropName)
    If i = -1 Then Exit Function   
     
    FileName = StrConv(FileName, vbUnicode)
    FilePath = StrConv(FilePath, vbUnicode)
     
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(FilePath, vbFromUnicode))
     
    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If
    If Not objFolderItem Is Nothing Then
        FileProperty = objFolder.GetDetailsOf(objFolderItem, i)
    Else
        FileProperty = vbNullString
    End If
     
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function

Sub ReadOutlookEmails3()
  'Tools > References... > Microsoft Outlook 16.0 Object Library
  Dim objFolder As Outlook.Folder, objNS As Outlook.Namespace
  Dim ws As Worksheet, tCount As Long, oItem As Object, a
  Dim i As Integer, j As Integer, k As Integer
  
  Set objNS = Outlook.GetNamespace("MAPI")
  Set objFolder = objNS.PickFolder
  AppActivate ThisWorkbook.Application.Caption
  If TypeName(objFolder) = "Nothing" Then Exit Sub
  
  tCount = 0
  For Each oItem In objFolder.Items
    'If TypeName(oItem) = "MailItem" Then
    If oItem.Class = olMail Then  'does same as above
      tCount = tCount + 1
    End If
  Next oItem

  If tCount = 0 Then Exit Sub
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  k = 13 'Number of columns
  ReDim a(1 To tCount, 1 To k)
  Set ws = Worksheets("Sheet2")
  With ws
    .UsedRange.ClearContents
    'Set column/header row 1 values
    .Range("A1:M1") = Split("Sender,To,Cc,Subject,Received Date,Received Time," _
      & "No of attachements,Body,Actions,Categories,FlagRequest,Importance,UnRead", ",")
  End With

  On Error Resume Next
  tCount = 0
  For Each oItem In objFolder.Items
    'If TypeName(oItem) = "MailItem" Then
    If oItem.Class = olMail Then
      tCount = tCount + 1
      For i = 1 To k
        With oItem
          a(tCount, i) = Choose(i, .SenderName, .To, .CC, .Subject, .ReceivedTime, _
            Format(CDate(.ReceivedTime), "HH:MM:SS"), .Attachments.Count, _
            .Body, .Actions, .Categories, .FlagRequest, .Importance, .UnRead)
        End With
      Next i
    End If
  Next oItem
  
  ws.Range("A2").Resize(tCount, 13) = a
  ws.UsedRange.EntireColumn.AutoFit
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic

  MsgBox "done"
End Sub

Sub ClickButton()
  Dim sShape As Shape, rowList As Object, j As Integer
  
  Debug.Print ActiveSheet.Shapes.Count
  Set rowList = CreateObject("System.Collections.ArrayList")
    For Each sShape In ActiveSheet.Shapes
    For j = 0 To 3
      rowList.Add sShape.TopLeftCell.Row + j
    Next j
    rowList.Add sShape.BottomRightCell.Row
  Next sShape
  If rowList.Count > 0 Then MsgBox (Join(rowList.toarray, vbLf))
  
  Set rowList = Nothing
End Sub