スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

Notesの書き出しファイルを読み込むプログラム

Option Explicit

Public Sub データクリア()
Cells.ClearContents
End Sub

Public Sub Notesデータ取り込み()

Dim buf As String
Dim nStart As Long 'nStart=bufの何個目から取るか
Dim dic As New Scripting.Dictionary
Dim buffer() As Byte, fileID As Integer
Dim r As Integer
Dim fn As String

'ファイルの取得
fn = prcApplicationGetOpenFilename
If fn = "" Then
MsgBox "ファイル名を指定してください。一旦終了"
Exit Sub
End If



fileID = FreeFile
Open fn For Binary As #fileID
ReDim buffer(LOF(fileID))
Get #fileID, , buffer
Close #fileID

nStart = 0
r = 2

データクリア
Application.ScreenUpdating = False

Do
nStart = GetLine(buffer, nStart, buf)

If InStr(1, buf, ":") > 0 Then
Dim Key As String
Key = Left(buf, InStr(1, buf, ":") - 1)
If dic.Exists(Key) Then
Else
With Range("IV1").End(xlToLeft).Offset(0, 1)
.Value = Key
dic.Add Key, .Column
End With
End If

buf = Replace(buf, Chr(1), vbTab) '変な空文字をタブに変える
buf = Replace(buf, Chr(0), vbCrLf) '変な空文字をタブに変える
Cells(r, dic(Key)).Value = Mid(buf, InStr(1, buf, ":") + 3, Len(buf))

End If

'--↓空がテキスト文字取込開始サイン--
If buf = "" Then
Dim msg As String

If dic.Exists("本文") = False Then
With Range("IV1").End(xlToLeft).Offset(0, 1)
.Value = "本文"
dic.Add "本文", .Column
End With
End If

nStart = Get本文(buffer, nStart, buf)
Cells(r, dic("本文")).Value = buf

'最終判定=本文後に改行
If buffer(nStart) = 13 And buffer(nStart + 1) = 10 Then Exit Do

r = r + 1
End If
Loop

Application.ScreenUpdating = True

End Sub


Private Function GetStringFromByte( _
ByRef buf() As Byte, _
ByRef Key() As Byte, _
ByVal nStart As Long, _
ByRef sRes As String) As Long

Dim i As Long, j As Long, k As Long, f As Boolean
Dim res() As Byte

For i = nStart To UBound(buf)
f = True
For j = 0 To UBound(Key)
If buf(i + j) <> Key(j) Then
f = False
Exit For
End If
Next j
If f = True Then
GetStringFromByte = i + UBound(Key) + 1
If i = nStart Then
sRes = ""
Else
ReDim res(i - nStart - 1)
For k = 0 To UBound(res)
res(k) = buf(nStart + k)
Next k
sRes = StrConv(res(), vbUnicode)
End If

Exit Function
End If
Next i
End Function


Private Function GetLine(ByRef buf() As Byte, ByVal nStart As Long, ByRef sRes As String) As Long
Dim Key(1) As Byte
Key(0) = 13: Key(1) = 10 '改行文字
GetLine = GetStringFromByte(buf, Key, nStart, sRes)
End Function

Private Function Get本文(ByRef buf() As Byte, ByVal nStart As Long, ByRef sRes As String) As Long
Dim Key(2) As Byte
Key(0) = 12: Key(1) = 13: Key(2) = 10 '改行文字
Get本文 = GetStringFromByte(buf, Key, nStart, sRes)
End Function




Public Function RepStr(s As String, org As String, rep As String) As String

Dim a As String
Dim i As Long
Dim j As Long
Dim k As Long

a = s
k = Len(org) - 1
j = Len(rep)
i = 1 - j
Do
i = InStr(i + j, a, org)
If i > 0 Then a = Left(a, i - 1) & rep & Right(a, Len(a) - i - k)
Loop Until i = 0

RepStr = a

End Function




Public Function prcApplicationGetOpenFilename() As String

Dim vntFileName As Variant

'ファイルを開くダイアログを開きます
vntFileName = _
Application.GetOpenFilename( _
FileFilter:="すべてのファイル (*.*),*.*" _
, FilterIndex:=1 _
, Title:="読み込みファイルの選択" _
, MultiSelect:=False _
)

'ファイルが選択されているときは
'選択したファイルをWorkbooks.Openメソッドで開きます
If vntFileName <> False Then
prcApplicationGetOpenFilename = vntFileName
End If

End Function
スポンサーサイト

トラックバック

コメント

コメントを残す

Secret



上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。