| |
こんにちは。かみちゃん です。
>>これらを実現するには、どうプログラムを修正すればよろしいでしょうか？
>>具体的にプログラムを書きなおしていただけると有り難いです。
>
>提示されたコードをできるだけ活かして書きなおすと以下のような感じでできると思います。
少し見直しました。こちらのほうがいいかと思います。
Option Explicit
Public Const adTypeText = 2
Public Const adReadLine = -2
Public Const adReadAll = -1
Public Const CONST_CHARSET = "iso-2022-jp"
Public Const CONST_MAIL_FOLDER_NAME = "eml"
Public Const DivideChar = "："
Public Const HeaderLine = 1
Sub Sample2()
Dim ts As Object ''テキストストリーム
Dim lngTextLineNumber As Long, lngCellLineNumber As Long
Dim ファイルパス As String, TextContents As String, LineContents() As String
Dim DivideCharPosition As Long
Dim FSO As Object
Dim TextFile As Object
Dim File As Object
Dim FolderPosition As String
Dim strKoumoku As String, ss As String
Dim lngCellColumnNumber As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
lngCellLineNumber = HeaderLine
FolderPosition = ThisWorkbook.Path & "\" & CONST_MAIL_FOLDER_NAME
For Each File In FSO.GetFolder(FolderPosition).Files
'ファイルをオープンする。（読み取り専用）
Set ts = CreateObject("ADODB.Stream")
'オブジェクトに保存するデータの種類を文字列型に指定する
ts.Type = adTypeText
'文字列型のオブジェクトの文字コードを指定する
ts.Charset = CONST_CHARSET
'オブジェクトのインスタンスを作成
ts.Open
'ファイルからデータを読み込む
ts.LoadFromFile (File.Path)
TextContents = ts.ReadText(adReadAll)
LineContents = Split(TextContents, vbCrLf)
lngCellLineNumber = lngCellLineNumber + 1
strKoumoku = "": ss = ""
For lngTextLineNumber = 0 To UBound(LineContents)
DivideCharPosition = InStr(LineContents(lngTextLineNumber), DivideChar)
'区切り文字が存在するか、項目名が取得できている場合処理する
If strKoumoku <> "" Or DivideCharPosition <> 0 Then
'区切り文字が存在する場合、項目名を取得する
If DivideCharPosition <> 0 Then
strKoumoku = Left(LineContents(lngTextLineNumber), DivideCharPosition - 1)
Select Case strKoumoku
Case "お名前"
lngCellColumnNumber = 1
Case "年月日"
lngCellColumnNumber = 3
Case "店員名"
lngCellColumnNumber = 5
Case "店の雰囲気"
lngCellColumnNumber = 6
Case "店のサービス"
lngCellColumnNumber = 8
Case "状況1"
lngCellColumnNumber = 10
Case "状況2"
lngCellColumnNumber = 11
Case "その他ご意見"
lngCellColumnNumber = 12
End Select
End If
'項目名が取得できている場合処理する
If strKoumoku <> "" Then
With Cells(lngCellLineNumber, lngCellColumnNumber)
If DivideCharPosition <> 0 Then
ss = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
If strKoumoku = "年月日" Then
ss = Replace(ss, " ", "")
ss = Mid(ss, 1, InStr(ss, "日"))
End If
.Value = ss
Else
.Value = .Value & LineContents(lngTextLineNumber)
End If
End With
End If
End If
Next lngTextLineNumber
ts.Close
Set ts = Nothing
Next File
Set FSO = Nothing
End Sub
|
|
かみちゃん
- 10/9/9(木) 13:12 -
