No. | 項目名 | タイプ | 桁数 | COBOL言語での編集 |
---|---|---|---|---|
1 | コード | 文字 | 5 | PIC X(05) |
2 | メーカー | 文字 | 10 | PIC X(10) |
3 | 品名 | 文字 | 15 | PIC X(15) |
4 | 数量 | 符号無数値 | 4 | PIC 9(04) |
5 | 単価 | 符号無数値 | 6 | PIC 9(06) |
6 | 金額 | 符号無数値 | 8 | PIC 9(08) |
計 | 48 |
'***************************************************************************************************
' 固定長形式テキストファイル書き出しサンプル(FSO) 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化、他
'21/06/27(1.11)不具合修正(FP_GetFixLeng:桁数判定不一致)
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "固定長形式テキストファイル書き出し"
Private Const g_cnsFilename As String = "SAMPLE1.dat"
'***************************************************************************************************
' ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :WRITE_FixLngFile1
'* 機能 :固定長形式テキストファイル書き出しサンプル(FSO)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月25日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:サンプルなのでエラー処理は行なっていません
'***************************************************************************************************
Sub WRITE_FixLngFile1()
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim objTs As TextStream ' TextStream
Dim lngRow As Long ' 収容するセルの行
Dim lngRowMax As Long ' データが収容された最終行
Dim lngRec As Long ' レコード件数カウンタ
Dim strFileName As String ' OPENするファイル名(フルパス)
'-----------------------------------------------------------------
Set objFso = New FileSystemObject
' フルパスファイル名の編集
strFileName = objFso.BuildPath(ThisWorkbook.Path, g_cnsFilename)
' 収容最終行の判定(Excel認知の最終行から上に向かってデータがある行を探す)
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData ' オートフィルタ解除
lngRowMax = Range("$A$" & Rows.Count).End(xlUp).Row
' データ未登録は終了
If lngRowMax < 2 Then
MsgBox "テキストをA列2行目から入力してから起動して下さい。", vbExclamation, g_cnsTitle
Set objFso = Nothing
Exit Sub
End If
'-----------------------------------------------------------------
' 指定ファイルをOPEN(出力モード)
Set objTs = objFso.CreateTextFile(Filename:=strFileName, Overwrite:=True)
Set objFso = Nothing
' 2行目から開始
lngRow = 2
'-----------------------------------------------------------------
' 最終行まで繰り返す
Do While lngRow <= lngRowMax
' レコード件数カウンタの加算
lngRec = lngRec + 1
Application.StatusBar = "出力中です....(" & lngRec & "レコード目)"
' レコードを出力(レコード編集処理より受け取る)
objTs.WriteLine FP_EditFixLngRec(lngRow) ' 改行(CrLf)付き
' objTs.Write FP_EditFixLngRec(lngRow) ' 改行(CrLf)なし
' 行を加算
lngRow = lngRow + 1
Loop
'-----------------------------------------------------------------
' 指定ファイルをCLOSE
objTs.Close
Set objTs = Nothing
Application.StatusBar = False
' 終了の表示
MsgBox "ファイル出力が完了しました。" & vbCr & _
"レコード件数=" & lngRec & "件", vbInformation, g_cnsTitle
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :FP_EditFixLngRec
'* 機能 :固定長形式テキストの1レコードの編集
'---------------------------------------------------------------------------------------------------
'* 返り値 :1レコード分の文字列(String)
'* 引数 :Arg1 = シート上の行(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月25日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_EditFixLngRec(ByVal lngRow As Long) As String
'-----------------------------------------------------------------------------------------------
Dim strRec As String ' レコードテキスト
' A列(コード)は5バイトの文字列
strRec = FP_GetFixLeng(Cells(lngRow, 1).Value, 5)
' B列(メーカー)は10バイトの文字列
strRec = strRec & FP_GetFixLeng(Cells(lngRow, 2).Value, 10)
' C列(品名)は15バイトの文字列
strRec = strRec & FP_GetFixLeng(Cells(lngRow, 3).Value, 15)
' D列(数量)は4バイトの数値
strRec = strRec & Format(Cells(lngRow, 4).Value, "0000")
' E列(単価)は6バイトの数値
strRec = strRec & Format(Cells(lngRow, 5).Value, "000000")
' F列(単価)は8バイトの数値
strRec = strRec & Format(Cells(lngRow, 6).Value, "00000000")
' 編集したレコード内容を戻り値にセット(計48バイト)
FP_EditFixLngRec = strRec
End Function
'***************************************************************************************************
'* 処理名 :FP_GetFixLeng
'* 機能 :指定バイト数の固定長データ作成(文字列処理)
'---------------------------------------------------------------------------------------------------
'* 返り値 :1項目分の文字列(String)
'* 引数 :Arg1 = 入力テキスト(String)
'* Arg2 = バイト数(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月25日
'* 作成者 :井上 治
'* 更新日 :2021年06月27日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_GetFixLeng(ByVal strInText As String, _
ByVal lngFixBytes As Long) As String
'-----------------------------------------------------------------------------------------------
Dim lngKeta As Long ' 項目桁数
Dim lngByte As Long ' バイト数
Dim lngByte2 As Long ' バイト数WORK
Dim lngByte3 As Long ' バイト数WORK
Dim lngIx As Long ' 文字位置INDEX
Dim intChar As Integer ' 文字コード
Dim strInText2 As String ' 入力文字列(Trim)
Dim strOutText As String ' 編集後文字列
strInText2 = Trim(strInText)
lngKeta = Len(strInText2)
'**********↓↓↓2021/06/27UPD↓↓↓(不具合修正:桁数不一致)
'strOutText = strInText ' ←NG
strOutText = strInText2 ' ←OK
'**********↑↑↑2021/06/27UPD↑↑↑
' バイト数判定
For lngIx = 1 To lngKeta
' 1文字ずつ半角/全角を判断
intChar = Asc(Mid(strInText2, lngIx, 1))
' 全角と判断される場合はバイト数に1を加える
If ((intChar < 0) Or (intChar > 255)) Then
lngByte2 = 2 ' 全角
Else
lngByte2 = 1 ' 半角
End If
' 桁あふれ判定(右切り捨て)
lngByte3 = lngByte + lngByte2
If lngByte3 >= lngFixBytes Then
If lngByte3 > lngFixBytes Then
strOutText = Left(strInText2, lngIx - 1)
Else
strOutText = Left(strInText2, lngIx)
lngByte = lngByte3
End If
Exit For
End If
lngByte = lngByte3
Next lngIx
' 桁不足判定(空白文字追加)
If lngByte < lngFixBytes Then
strOutText = strOutText & Space(lngFixBytes - lngByte)
End If
FP_GetFixLeng = strOutText
End Function
'----------------------------------------<< End of Source >>----------------------------------------
' レコードを出力(REC編集処理より受け取る)
objTs.WriteLine FP_EditFixLngRec(lngRow) ' 改行(CrLf)付き
' objTs.Write FP_EditFixLngRec(lngRow) ' 改行(CrLf)なし
プラス値 | マイナス値 | ||||||
---|---|---|---|---|---|---|---|
数値 | EBCDIC コード |
文字 | Ascii コード |
数値 | EBCDIC コード |
文字 | Ascii コード |
+9 | C9 | I | 49 | -1 | D1 | J | 4A |
+8 | C8 | H | 48 | -2 | D2 | K | 4B |
+7 | C7 | G | 47 | -3 | D3 | L | 4C |
+6 | C6 | F | 46 | -4 | D4 | M | 4D |
+5 | C5 | E | 45 | -5 | D5 | N | 4E |
+4 | C4 | D | 44 | -6 | D6 | O | 4F |
+3 | C3 | C | 43 | -7 | D7 | P | 50 |
+2 | C2 | B | 42 | -8 | D8 | Q | 51 |
+1 | C1 | A | 41 | -9 | D9 | R | 53 |
+0 | C0 | { | 7B | -0 | D0 | } | 7D |