Option Explicit
Dim fso
Dim Path
Dim FolderName
dim k
Set fso=CreateObject("Scripting.FileSystemObject")
For Each Path In WScript.Arguments
FolderName=fso.BuildPath(fso.GetParentFolderName(Path),fso.GetBaseName(Path))
If fso.FolderExists(FolderName) Then
For k=2 To 9
If Not fso.FolderExists(FolderName & " " & k) Then Exit For
Next
FolderName=FolderName & " " & k
End If
if instr (1,FolderName,"?",0) Then
FolderName = Replace(FolderName, "?", "_[?]_") & "_●●●●●Use_Unicode●●●●●"
'MsgBox FolderName,vbOKOnly
fso.CreateFolder FolderName
else
fso.CreateFolder FolderName
Call Expand(Path,FolderName)
end if
Next
Sub Expand(Path,Folder)
Dim Stm
Dim Msg
Dim File
Dim RenBatFile
Set Stm=CreateObject("ADODB.Stream")
Stm.Open
Stm.LoadFromFile Path
set Msg=createobject("CDO.Message")
Msg.DataSource.OpenObject Stm, "_Stream"
Set File=fso.CreateTextFile(Folder & "\index.html")
File.WriteLine "<table border><thead><td>File</td><td>Content-Type</td><td>Content-Location</td></thead><tbody>"
Set RenBatFile=fso.CreateTextFile(Folder & "\_rename.bat")
Call SaveToFile(Msg.BodyPart,"1",Folder,File,RenBatFile)
File.WriteLine "</tbody></table>"
File.Close
RenBatFile.WriteLine "ren _rename.bat rename.bat"
RenBatFile.Close
'MsgBox "変換完了",vbOKOnly
End Sub
Sub SaveToFile(BodyPart,BaseName,Folder,File,RenBatFile)
Dim k
Dim memfnamenum
Dim memfnameorg
If BodyPart.BodyParts.Count Then
For k=1 To BodyPart.BodyParts.Count
Call SaveToFile(BodyPart.BodyParts.Item(k),BaseName & "." & right("00000" & Cstr(k) , 5),Folder,File,RenBatFile)
Next
Else
File.WriteLine "<tr><td>" & BaseName & "</td><td>" & BodyPart.Fields.Item("urn:schemas:mailheader:content-type") & "</td><td>" & fso.GetFileName(BodyPart.Fields.Item("urn:schemas:mailheader:content-location")) & "</td><td>" & BodyPart.Fields.Item("urn:schemas:mailheader:content-location") & "</td></tr>"
BodyPart.SaveToFile Folder & "\" & BaseName & ".txt"
memfnamenum=BaseName
memfnameorg=fso.GetFileName(BodyPart.Fields.Item("urn:schemas:mailheader:content-location"))
memfnameorg = Replace(memfnameorg, "\", "¥")
memfnameorg = Replace(memfnameorg, "/", "/")
memfnameorg = Replace(memfnameorg, ":", ":")
memfnameorg = Replace(memfnameorg, "*", "*")
memfnameorg = Replace(memfnameorg, "?", "?")
memfnameorg = Replace(memfnameorg, """", Chr(&H8168)) ' VBAでは全角のダブルクォーテーションが打てない
memfnameorg = Replace(memfnameorg, "<", "<")
memfnameorg = Replace(memfnameorg, ">", ">")
memfnameorg = Replace(memfnameorg, "|", "|")
memfnameorg = Replace(memfnameorg, "=", "=")
memfnameorg = Replace(memfnameorg, "&", "&")
memfnameorg = left(memfnameorg,100)
RenBatFile.WriteLine "ren " & memfnamenum & ".txt " & memfnameorg
End If
End Sub