'***************************************************************************************************
' 固定長形式テキストファイルを読み込むサンプル(改行あり) Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft Scripting Runtime
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'03/07/25(1.00)新規作成
'03/12/04(1.01)初回修正
'20/02/26(1.10)*.xlsm化、他
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "固定長形式テキストファイル読み込み"
Private Const g_cnsFilename As String = "SAMPLE1.dat"
'***************************************************************************************************
' ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :READ_FixLngFile1
'* 機能 :固定長形式テキストファイルを読み込むサンプル(改行あり)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月25日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:サンプルなのでエラー処理は行なっていません
'***************************************************************************************************
Sub READ_FixLngFile1()
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim objTs As TextStream ' TextStream
Dim lngRow As Long ' 収容するセルの行
Dim lngRec As Long ' レコード件数カウンタ
Dim strRec As String ' レコードを収容する変数
Dim strFileName As String ' OPENするファイル名(フルパス)
'-----------------------------------------------------------------
Set objFso = New FileSystemObject
' フルパスファイル名の編集
strFileName = objFso.BuildPath(ThisWorkbook.Path, g_cnsFilename)
' 指定ファイルをOPEN(入力モード)
Set objTs = objFso.OpenTextFile(Filename:=strFileName, IOMode:=ForReading)
Set objFso = Nothing
' 2行目から開始
Rows("2:" & Rows.Count).ClearContents
lngRow = 2
'-----------------------------------------------------------------
' ファイルのEOFまで繰り返す
Do Until objTs.AtEndOfStream
' レコード件数カウンタの加算
lngRec = lngRec + 1
Application.StatusBar = "読み込み中です....(" & lngRec & "レコード目)"
' 改行までをレコードとして読み込む
strRec = StrConv(objTs.ReadLine, vbFromUnicode)
' 1レコード分のセルへのセット
Call GP_EditFixLngRec(strRec, lngRow)
' 行を加算
lngRow = lngRow + 1
Loop
'-----------------------------------------------------------------
' 指定ファイルをCLOSE
objTs.Close
Set objTs = Nothing
Application.StatusBar = False
' 終了の表示
MsgBox "ファイル読み込みが完了しました。" & vbCr & _
"レコード件数=" & lngRec & "件", vbInformation, g_cnsTitle
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_EditFixLngRec
'* 機能 :CSV形式テキストの1レコードのセルへの転記
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = 読み込みレコード内容(String)
'* Arg2 = 収容するセルの行(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月25日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_EditFixLngRec(ByVal strRec As String, ByVal lngRow As Long)
'-----------------------------------------------------------------------------------------------
' A列(コード)は5バイトの文字列処理
Cells(lngRow, 1).Value = FP_GetFldFromRecS(strRec, 1, 5)
' B列(メーカー)は10バイトの文字列処理
Cells(lngRow, 2).Value = FP_GetFldFromRecS(strRec, 6, 10)
' C列(品名)は15バイトの文字列処理
Cells(lngRow, 3).Value = FP_GetFldFromRecS(strRec, 16, 15)
' D列(数量)は4バイトの数値処理
Cells(lngRow, 4).Value = FP_GetFldFromRecN(strRec, 31, 4)
' E列(単価)は6バイトの数値処理
Cells(lngRow, 5).Value = FP_GetFldFromRecN(strRec, 35, 6)
' F列(金額)は8バイトの数値処理
Cells(lngRow, 6).Value = FP_GetFldFromRecN(strRec, 41, 8)
End Sub
'***************************************************************************************************
'* 処理名 :FP_GetFldFromRecS
'* 機能 :固定長データから指定バイト数を切り出す(文字列処理)
'---------------------------------------------------------------------------------------------------
'* 返り値 :取得した文字列(String)
'* 引数 :Arg1 = 読み込みレコード内容(String)
'* Arg2 = 開始バイト位置(Long)
'* Arg3 = 項目バイト数(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月25日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_GetFldFromRecS(ByVal strRec As String, _
ByVal lngStrPos As Long, _
ByVal lngLngs As Long) As String
'-----------------------------------------------------------------------------------------------
FP_GetFldFromRecS = Trim(StrConv(MidB(strRec, lngStrPos, lngLngs), vbUnicode))
End Function
'***************************************************************************************************
'* 処理名 :FP_GetFldFromRecN
'* 機能 :固定長データから指定バイト数を切り出す(整数処理)
'---------------------------------------------------------------------------------------------------
'* 返り値 :取得した数値(Currency)
'* 引数 :Arg1 = 読み込みレコード内容(String)
'* Arg2 = 開始バイト位置(Long)
'* Arg3 = 項目バイト数(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月25日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_GetFldFromRecN(ByVal strRec As String, _
ByVal lngStrPos As Long, _
ByVal lngLngs As Long) As Currency
'-----------------------------------------------------------------------------------------------
Dim strRec2 As String ' 切り出した文字列
strRec2 = StrConv(MidB(strRec, lngStrPos, lngLngs), vbUnicode)
FP_GetFldFromRecN = CCur(strRec2)
End Function
'----------------------------------------<< End of Source >>----------------------------------------