Posts by Kenneth Hobson
Here is an example using exiftool that I worked up for you.Code
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
If you attach a pdf file, and tell me the metadata fieldnames, I can better help.
For the standard Acrobat GetInfo() fields, that is easy as you saw.
For the xmp metadata fields, even the itextsharp does not return individual fields. It looks like it is returning all xmp metadata as a string. I suspect that you would have to parse it out too. If you can generate the xmp file data as you did, parsing it might be doable. If that interest you, we can pursue that.
If I had the example pdf file with the known fieldnames with values to retrieve, the exiftool returns metadata but from the xmp, I am not sure. Here is an example output to a csv file. Row 2 does not align here in the pasted text but I think you get it.
MicrosoftÂ® ExcelÂ® 2010
SourceFile ExifToolVersion FileName Directory FileSize FileModifyDate FileAccessDate FileCreateDate FilePermissions FileType FileTypeExtension MIMEType PDFVersion Linearized PageCount Language TaggedPDF Author CreateDate ModifyDate Producer Creator ken.pdf 12.17 . 2018:08:02 09:04:49-05:00 2021:05:15 11:31:26-05:00 application/pdf 1.5 2 Yes 2018:08:02 09:04:49-05:00 MicrosoftÂ® ExcelÂ® 2010
The command to generate in a CMD prompt would be something like:
I can only guess at why your Shell() command failed since you did not post code. For the string in Shell() for exiftool, one would use the full drive:\path\filename.ext. Those would be double quote encapsulated. Normally, I do Win+R, CMD, Enter, and then, D:, cd myfiles\exiftool. My ken.pdf was in that folder. I copied my exiftool(-k).exe to exiftool.exe so that I could use the command line switches. If you click the -k file in file explorer, the help file will show in a CMD window.
Here is -all option for the same file in exiftool. As you can see, it may well get all that you need.Quote
D:\MyFiles\exiftool>exiftool -all ken.pdf
ExifTool Version Number : 12.17
File Name : ken.pdf
Directory : .
File Size : 97 KiB
File Modification Date/Time : 2018:08:02 09:04:49-05:00
File Access Date/Time : 2021:05:16 09:47:07-05:00
File Creation Date/Time : 2021:05:15 11:31:26-05:00
File Permissions : rw-rw-rw-
File Type : PDF
File Type Extension : pdf
MIME Type : application/pdf
PDF Version : 1.5
Linearized : No
Page Count : 2
Language : en-US
Tagged PDF : Yes
Author : Kenneth Ray Hobson
Create Date : 2018:08:02 09:04:49-05:00
Modify Date : 2018:08:02 09:04:49-05:00
Producer : Microsoft┬« Excel┬« 2010
Creator : Microsoft┬« Excel┬« 2010
For the most part, I think that the itextsharp.dll is for those without Acrobat. I had a book for itextsharp but when I loaned it out, it was never returned. I had the University of Oklahoma do a research project for me to build a pdf using that DLL. I posted a tutorial for how to use it using vb.net. Using itextsharp might be more appropriate for a c# or vb.net forum. I have not used that in VBA. My tutorial is applicable for vb.net users. The EXE that I created from it can be used by most programming languages. The link is at a WordPerfect forum. My old itextsharp vb.net tutorial is at: https://www.wpuniverse.com/vb/…s-Parameters-5-iTextSharp
This thread has gotten so long, I forgot if I discussed exiftool. It does not work with all applications but PDF has the most features in it. I have used Shell() to execute the exiftool.exe with command line switches. If that interests you, see: exiftool.org
Here is an example to strip "all" metada from a PDF file using Acrobat and exiftool.Code
'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
I used ChilKat many years ago for XML parsing.
I will look at some SDK's tonight to see if there is a COM method to get xmp metadata.
One does not see much about that for VBA in a web search. It seems like it may be complex. Look in: Acrobat JS API Reference
Something here might be of use. https://www.adobe.com/devnet/xmp.html
See my response in your cross-post. http://www.vbaexpress.com/foru…ored-Inside-an-Excel-Cell
For what it is worth, here is #4 link's code but with early binding.Code
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
It would advise removing that link. Those sorts of things can be found for those that want it.
I am glad that you found my code useful. I will try doing a similar thing with Acrobat when I get v6.
Here is the GetDetailsOf version will ALL names and property values. Just modify the INPUTS commented block in first sub and run it. The inputs do not have to be just pdf files. As before, run with activesheet being empty/blank.Code
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
For a beginner you seem to grasp more than many.
Unfortunately, my computer at work no longer has Acrobat. I will get an old Acrobat version 6 and see if it would work for metadata. I wish Adobe had not gone the way of leasing software.
For the interim, I did some preparatory work for a GetDetailsOF approach. It does not apply to your needs but many concepts could be used in your project.
Normally, when I use GetDetailsOf method, I only need a few properties/metadata. With the needs of your project in mind, I fleshed most of this out tonight. Put it into a Module, change pPDF value line in first sub and run it with a blank worksheet active. Cell B2 and to the right will have 322 columns filled. Some are blank because it has no property name for that index position.
If you examine the code, you will see comments with some good tips. Debug.Print lines were left in as they are good for testing but also show how some things can be shown. I most always code like this.
The ArrayList method offers some nice features that we can use later in the file iterative loop. e.g. We may just use say 5 property field values. We would get the names, and with IndexOf, we can get just the value from another ArrayList with the values in the same index order. Most people, just hard code the index in. 99.9% of the time, that would be sufficient. Howsoever, every once in a while, Microsoft does an upgrade that could impact the code.
This conceptual approach also offers a more dynamic potential. e.g. Data Validation list with all property names in B2. When one is picked for the file in A2, then C2 will be updated with that property value. That way, 322 columns are not needed but readily found.
Anyway, if you want to give it a run, change the pPDF value and run...Code
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
You can iterate i=0 to 100 or such. I say 100 because the stack in Immediate window is limited. Then do 101 to 200. The number of properties varies by file type. 350 should get most all. If coded right, one can put "" as the file base name and it returns the property name. I have put all of that into a worksheet so loop count is not limited. I would use Debug.Print i, s. The "s" is the property value found. The "i" reminds you which index number the value came from.
GetDetailsOf method is nice but of limited use to you it sounds like.
File property information can also be found using a Shell() to an application like exiftool. It does not get all file types but for those that it does, it can read and sometimes write those properties back. PDF is one that it handles well. Most use it for media file types. Its command line switches can be short but powerful. It is a good tool to consider depending on the project.
Sure, just attach the sample workbook with the header column names arranged the way you want for metadata.
I was a little sick so I won't get to my work computer until tomorrow to check this. For the GetInfo() metadata, I will be curious to see if GetDetailsOf() would produce the same result.
Adobe's other methods like .GetNumPages is nice to have.
When you run that code, Debug.Print puts the results in the VBE, Immediate Window. Select View in VBE to view that window if not active.
Post back if you need more help. Attaching a short example file with the column headings would help us help you a bit easier. Click the Attachments link at end of reply box.
It takes a bit more work but I like to put all results into an array and then write to the worksheet once. Writing to sheet one cell at a time is very slow.
I will have access to my Acrobat library in 2 days and can see if code in this link would work. For now, you can look for the two classes, as seen in the code, in your Registry. If there, you can try this code:
Another quick way to check is to copy the code and then in VBE, Debug > Compile. If no compile error, the two classes should be in your registry.
The file probably came from an outside source.
1. Open File Explorer (Win+E)
2. Right click the CHM file
3. View Properties.
4. Bottom Right should be an UnBlock checkbox. Check it.
5. Apply, OK.
Welcome to the forum!
You installed Adobe Pro? If so, you should have AcroExch object in VBE > Tools > References. I would post code that I found but I don't have Pro version installed on this computer. I like to test code before I post it.
Are these metadata values the same as File property values as seen in File Explorer? Is so, you can use the GetDetailsOf() method. e.g.Code
'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
For the files stored locally, it is easy to get your path in File Explorer.
This is probably of limited or no help at all. I have 3 OneDrive entries in the registry. Likely you would want the OneDriveCommercial. If the goal is to find the local path for any logged in user, one can get that from the Registry HCU\Environment. Of course that can be automated in VBA.
Maybe something like this but you may want to add the filter by date. I was not sure what you wanted with that. I removed some things so I could work up this example.Code
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
Welcome to the forum!
Sounds like a home work problem for Open Channel Flow course. Here is the course I took many years ago and did that. https://www.coursicle.com/ou/courses/CEES/4123/
A search of the web should show many sites to do this common task. This site shows two of those. https://www.extendoffice.com/d…-under-plotted-curve.html
I can not duplicate your problem. I tried ActiveX and Forms command buttons and shape controls.Code
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