时间戳

首页 > 解决方案 > Excel VB - Shell 对象和 Items 扩展属性

excel - Excel VB - Shell 对象和 Items 扩展属性

问题描述

首先，我不是 VB 极客，但我通过谷歌搜索找到了自己的方式，但我就是想不通这个......

简而言之，我制作了一个宏，允许我选择 pdf，压缩它们，并在另一张纸上构建这些压缩文件的列表，然后自动准备一封带有该 zip 作为附件的电子邮件。我希望该列表包含以下条目：

就像我说的，我不是程序员，我知道我的代码不是最优的，所以请不要评判我。我只是想让它工作，然后我会优化它；）

要获取 title 属性，我使用以下代码：

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

“DocTitle”是标题的属性名称。我只是找不到提取“标签”是什么，我尝试了“标签”、“DocTags”和“关键字”，但我一无所获。我试过使用 GetDetailsOf("FILE", 18)，但它返回字符串“Tags”，而不是实际的标签......就像......标签的标题......

这是完整的代码：

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

要使代码完全工作，您必须安装 Outlook。但即使没有 Outlook，列表生成也能正常工作。感谢您的帮助，以及您的时间！

标签： excelvb.netextended-properties

解决方案

推荐阅读