Question

我有一个现有的xls文件，它根据目录中的文件创建一个CONTENTS文件。例如，如果目录包含file.pdf和file.txt，它将创建一个包含内容

的文件

file.pdf
file.txt

每个文件用换行符分隔。

我想做的是我希望内容包含

file.pdf    bundle:ORIGINAL
file.txt    bundle:TEXT

file.pdf和bundle:ORIGINAL由tab字符分隔。该目录将包含这2个文件类型，1个pdf和1个文本文件。所以基本上，我想要的是，对于每个pdf文件，它应该跟bundle:ORIGINAL文本后面，如果它是一个文本文件，它应该后跟bundle:TEXT。

原始代码如下：

For i = 2 To lRows
If Trim(Cells(i, 1).Value) = "" Then Exit For

' create the CONTENTS file

FileList = GetFileList(oDirectory & "\" & Trim(Cells(i, lCols).Value) & "\")
cFileNum = FreeFile
ContentsPath = oDirectory & "\" & Trim(Cells(i, lCols).Value) & "\" & "contents"
Open ContentsPath For Output As #cFileNum
For k = 1 To UBound(FileList)
If (FileList(k) <> "contents" And FileList(k) <> "dublin_core.xml") Then
    Print #cFileNum, FileList(k)
    End If
    Next k
Close #cFileNum

修改

这是函数GetFileList

Function GetFileList(FileSpec As String) As Variant
'   Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False

Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String

On Error GoTo NoFilesFound

FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound

'   Loop until no more matching files are found
Do While FileName <> ""
    FileCount = FileCount + 1
    ReDim Preserve FileArray(1 To FileCount)
    FileArray(FileCount) = FileName
    FileName = Dir()
Loop
GetFileList = FileArray
Exit Function

'   Error handler
NoFilesFound:
GetFileList = False
End Function

请注意，我显然不是此代码的作者，很久以前我刚刚下载了这个excel文件（网站不再存在），我只需要调整一下供我自己使用。

提前致谢。

Answer 1

这样的事情应该这样做：

'...
If (FileList(k) <> "contents" And FileList(k) <> "dublin_core.xml") Then
    Print #cFileNum, FileList(k) & vbTab & GetType(Cstr(FileList(k)))
End If
'...

功能：

Function GetType(fName as string)
    Dim rv As String
    Select Case Right(Ucase(fName),3)
        Case "TXT": rv = "bundle:TEXT"
        Case "PDF": rv = "bundle:ORIGINAL"
    End Select
    GetType = rv
End Function

如何使用基于目录中文件的内容创建文件

1 个答案: