IT・Office

VBAサンプル

更新日:

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 Integer
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
test = errFlg.Error

' インプットファイルがない場合は終了
' TODO:Thenで処理できないか
If fso.FileExists(readPath) Then
Else
MsgBox filename & "が存在しません"
Exit Sub
End If

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

Dim record As Variant

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

' 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

' 書き込み処理
writeFile Jt119, writePath, stream

Loop

' fso.Close
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

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

Function writeFile(entity As EntityJT119, path As String, stream As ADODB.stream) As Boolean
writeFile = False

On Error GoTo Err

With stream
.Type = adTypeText
.Charset = "UTF-8"
.LineSeparator = adLF
.LoadFromFile path
.Position = .Size

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

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

' .SaveToFile path, adSaveCreateOverWrite

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

Dim buf As Variant

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

writeFile = True

Err:
If Err.Number <> 0 Then
Debug.Print "writeFile(): " & Err.Description
End If
End Function

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

' 参考:format関数
' http://beatdjam.hatenablog.com/entry/2014/08/06/163224

Dim work As String

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

'正規表現の指定
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

value = airport(0) & airport(1)

End Function

######

Public test1 As String
Public test2 As String
Public test3 As String

Property Get HEAD1() As String
HEAD1 = "見出し1"
End Property
Property Get HEAD2() As String
HEAD2 = "見出し2"
End Property
Property Get HEAD3() As String
HEAD3 = "見出し3"
End Property

-IT・Office

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