Chameleon Cyber

Sub createLogFile(LogFilePath As String, subject As String, time As String, body As String)
    'ログファイルの生成の実験用
    Dim n As Long
    n = FreeFile
    Open LogFilePath & "\MailLog.csv" For Output As #n
        Print #n, subject & "," & time & "," & body & vbCrLf
    Close #n
End Sub
 
Public Sub SaveFile()
    'Copyright Chameleon 2007 Ver.0.0.2
    'メインルーチン
     Dim i, x, count As Integer
    Dim strFolder As String
    Dim ns As NameSpace
    Dim mf As MAPIFolder
    Dim n As Long
    Dim message As String
 
    strFolder = getItemFolder()
 
    Set ns = GetNamespace("MAPI")
    Set myInbox = ns.GetDefaultFolder(olFolderInbox)
    Set myDestFolder = myInbox.Folders("本社メール")
    Set myItems = myDestFolder.Items
 
    n = FreeFile
    Open strFolder & "\MailLog.csv" For Append As #n
    For x = 1 To myItems.count
        With myItems.Item(x)
            count = 0
            count = .Attachments.count
            If count > 0 Then
                For i = 1 To count
                    'Debug.Print .subject
                    'message = .body
                    'Debug.Print message
                    Print #n, .subject & "," & .ReceivedTime ' & "," & message
                    .Attachments(i).SaveAsFile (strFolder & "\" & .Attachments(i).DisplayName & ".msg")
                    .Delete
                Next
            End If
        End With
    Next
    Close #n
End Sub
 
Function getItemFolder() As String
    '保存先決定用
    Dim DesktopPath As String
    Dim objShell As Object  'Shell
    Dim objFolder As Object 'Shell32.Folder
 
    Const strTitle = "フォルダを選択してください。"
    Const lngRef = &H1
    Const fldRoot = &H0
 
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, strTitle, lngRef, fldRoot)
 
    DesktopPath = CreateObject("WScript.Shell").SpecialFolders("desktop")
 
    If objFolder Is Nothing Then
        getFOLDER = "キャンセル"
    Else
        If objFolder.ParentFolder Is Nothing Then
            getItemFolder = DesktopPath
        Else
            getItemFolder = objFolder.Items.Item.Path
        End If
    End If
 
    Set objFolder = Nothing
    Set objShell = Nothing
End Function