IT・Office

VBAサンプル2

更新日:

Option Explicit
' Functionの戻り値に使用
Public Enum errFlg
Normal = 0
warning1 = 1
warning2 = 2
Error = 3
End Enum

Private aCnt As Long
Private bCnt As Long

' ##########################################################
' ・参照設定で「MicrosoftScriptingLutime」にチェックを入れる
' ・宣言→インスタンス化
' ・存在チェックはIf fso.FileExists(path) Then Else Exit Sub End If
' ・ファイルオープンはインスタンス名.OpenTextFile
' ・1行ずつ読み込む場合はインスタンス名.ReadLine、全行読み込む場合はReadAll
' ・EOFはインスタンス名.AtEndOfStream
' http://officetanaka.net/excel/vba/filesystemobject/filesystemobject25.htm
' ##########################################################

Sub fsoTest()

Dim Jt119 As EntityJT119
Dim fso As Scripting.FileSystemObject
Dim path As String
Dim filename As String
Dim cnt As Long
Dim readPath As String
Dim writePath As String
Dim stream As ADODB.stream
Dim reg As Object
Dim value As String ' 値引き渡し用

Set Jt119 = New EntityJT119
Set fso = New FileSystemObject
Set stream = New ADODB.stream
Set reg = CreateObject("VBScript.RegExp")

readPath = "testfile.txt" ' 相対パスで指定
writePath = "output.txt" ' 相対パスで指定
filename = "testfile.txt"
cnt = 0
aCnt = Range("F10").value

bCnt = Range("F12").value

Dim test As Variant

' If Dir("testfile.txt1") = "" Then
' MsgBox "nothing"
' Exit Sub
' Else
' MsgBox "OK"
' End If
' Exit Sub

' インプットファイルがない場合は終了
If fso.FileExists(readPath) = False Then
MsgBox filename & "が存在しません"
Exit Sub
End If

' Open
Dim inRecord As Variant
Set inRecord = fso.OpenTextFile(readPath)

Dim record As Variant

' ファイル作成+見出し書き込み
' writeFileInit Jt119, writePath, stream

With stream
.Type = adTypeText
.Charset = "UTF-8"
.LineSeparator = adLF
.Open
.SaveToFile writePath, adSaveCreateOverWrite
End With

' 1行スキップ(空読み)
record = inRecord.ReadLine

' 最後の行までループ
Do Until inRecord.AtEndOfStream

' 1行ずつRead
record = inRecord.ReadLine
cnt = cnt + 1
aCnt = aCnt - 1
bCnt = bCnt - 1

' タブで分割処理
DevideLine record, Jt119

' 各カラムごとの処理

' 判定
value = Jt119.test3
CheckFormat value, reg
Jt119.test3 = value

' 空港を判定
value = Jt119.test2
CheckFormatCode value, reg
Jt119.test2 = value

' 書き込み処理
Call writeFile(Jt119, writePath, stream, cnt)

Loop

Call writeFileEof(Jt119, writePath, stream, cnt)

Set fso = Nothing

MsgBox "終了"

End Sub

Function DevideLine(ByRef record As Variant, Jt119 As EntityJT119)

Dim buf As Variant
buf = Split(record, vbTab)

With Jt119
.test1 = buf(0)
.test2 = buf(1)
.test3 = buf(2)
End With

DevideLine = True

End Function

' ファイルの初期処理(アウトプットファイル作成、見出し書き込み)
'Public Sub writeFileInit(entity As EntityJT119, path As String, stream As ADODB.stream)
'
' With stream
' .Type = adTypeText
' .Charset = "UTF-8"
' .LineSeparator = adLF
' .Open
' .writeText entity.HEAD1
' .writeText vbTab
' .writeText entity.HEAD2
' .writeText vbTab
' .writeText entity.HEAD3, adWriteLine
'
' .SaveToFile path, adSaveCreateOverWrite
' End With
'
'End Sub

' ##############################################################
' 書き込み
' ##############################################################

Sub writeFile(entity As EntityJT119, path As String, stream As ADODB.stream, cnt As Long)

Dim limit As Long
limit = 10

With stream
.LoadFromFile path
.Position = .Size

' 各項目をセット、書き込み

.writeText entity.test1
.writeText vbTab
.writeText entity.test2
.writeText vbTab
.writeText entity.test3, adWriteLine

If cnt >= limit Then
.SaveToFile path, adSaveCreateOverWrite
End If

End With

End Sub

' ##############################################################
' 書き込み
' ##############################################################

Sub writeFileEof(entity As EntityJT119, path As String, stream As ADODB.stream, cnt As Long)

With stream
.LoadFromFile path
.Position = .Size
End With

If stream.Size > 0 Then
stream.SaveToFile path, adSaveCreateOverWrite
End If

End Sub

Function bom()

.Position = 0
.Type = adTypeBinary
.Position = 3

Dim buf As Variant

buf = .read()
.Position = 0
.Write buf
.SetEOS
.SaveToFile path, adSaveCreateOverWrite

End Function

Function CheckFormat(ByRef value As String, reg As Object)

Dim work As String

' ゼロパディング
work = Format(Mid(value, 3, 4), "0000")
value = Left(value, 2) & work

'正規表現の指定
With reg
.Pattern = "[J][L][0-9]{4}" ' JL0000
.IgnoreCase = True ' 大文字のみ許可(True)
.Global = True ' 文字列全体を検索(True)
End With

' フォーマットが正しければTrue、誤りならばFalse
If reg.test(value) Then
CheckFormat = True
Else
CheckFormat = False
End If

End Function

Function CheckFormatCode(ByRef value As String, reg As Object)

' https://rubular.com/
' スペース埋めはairport() = Format(xxx, "@@@")

CheckFormatCode = True

Dim airport(1) As String

airport(0) = Left(value, 3)
airport(1) = Mid(value, 4, 3)

'正規表現の指定
With reg
.Pattern = "[A-Z]{3}"
.IgnoreCase = True ' 大文字のみ許可(True)
.Global = True ' 文字列全体を検索(True)
End With

' 空港名を判定(from)
If reg.test(airport(0)) Then
Else
airport(0) = " "
CheckFormatCode = False
End If

' 空港名を判定(to)
If reg.test(airport(1)) Then
Else
airport(1) = " "
CheckFormatCode = False
End If

End Function

-IT・Office

Copyright© hobby23 , 2019 All Rights Reserved Powered by AFFINGER5.