【Excel】输出固定长文本

'*******************************************************************************
'   固定長形式テキストファイル書き出すサンプル(FSO)
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
' [参照設定]
'   ・Microsoft Scripting Runtime
'*******************************************************************************
Option Explicit

'*******************************************************************************
' 固定長形式テキストファイル書き出すサンプル(FSO)
' 参照設定：Microsoft Scripting Runtime
'*******************************************************************************
Sub WRITE_FixLngFile1()
    Const cnsFILENAME = "\SAMPLE.dat"
    Dim FSO As New FileSystemObject         ' FileSystemObject
    Dim TS As TextStream                    ' TextStream
    Dim GYO As Long                         ' 収容するセルの行
    Dim GYOMAX As Long                      ' データが収容された最終行

    ' 最終行の取得
    With ActiveSheet
        If .FilterMode Then .ShowAllData
    End With
    GYOMAX = Range("A65536").End(xlUp).Row
    ' 指定ファイルをOPEN(出力モード)
    Set TS = FSO.CreateTextFile(Filename:=ThisWorkbook.Path & cnsFILENAME, _
                                Overwrite:=True)
    ' 2行目から開始
    GYO = 2
    ' 最終行まで繰り返す
    Do Until GYO > GYOMAX
        ' レコードを出力(REC編集処理より受け取る)
        TS.WriteLine FP_EDIT_FixLngRec(GYO)         ' 改行(CrLf)付き
'        TS.Write FP_EDIT_FixLngRec(GYO)             ' 改行(CrLf)なし
        ' 行を加算
        GYO = GYO + 1
    Loop
    ' 指定ファイルをCLOSE
    TS.Close
    Set TS = Nothing
    Set FSO = Nothing
End Sub

'*******************************************************************************
' CSV形式テキストの1レコードの編集処理
'*******************************************************************************
Private Function FP_EDIT_FixLngRec(GYO As Long) As String
    Dim strREC As String

    ' A列(コード)は5バイトの文字列処理
    strREC = FP_GET_FIXLNG(Cells(GYO, 1).Value, 5)
    ' B列(メーカー)は10バイトの文字列処理
    strREC = strREC & FP_GET_FIXLNG(Cells(GYO, 2).Value, 10)
    ' C列(品名)は15バイトの文字列処理
    strREC = strREC & FP_GET_FIXLNG(Cells(GYO, 3).Value, 15)
    ' D列(数量)は4バイトの数値処理
    strREC = strREC & Format(Cells(GYO, 4).Value, "0000")
    ' E列(単価)は6バイトの数値処理
    strREC = strREC & Format(Cells(GYO, 5).Value, "000000")
    ' F列(単価)は8バイトの数値処理
    strREC = strREC & Format(Cells(GYO, 6).Value, "00000000")
    ' 編集したレコード内容を戻り値にセット(計48バイト)
    FP_EDIT_FixLngRec = strREC
End Function

'*******************************************************************************
' 指定バイト数の固定長データ作成(文字列処理)
'*******************************************************************************
Private Function FP_GET_FIXLNG(strInText As String, _
                               lngFixBytes As Long) As String
    Dim lngKeta As Long
    Dim lngByte As Long, lngByte2 As Long, lngByte3 As Long
    Dim IX As Long
    Dim intCHAR As Integer
    Dim strOutText As String

    lngKeta = Len(strInText)
    strOutText = strInText
    ' バイト数判定
    For IX = 1 To lngKeta
        ' 1文字ずつ半角/全角を判断
        intCHAR = Asc(Mid(strInText, IX, 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(strInText, IX - 1)
            Else
                strOutText = Left(strInText, IX)
                lngByte = lngByte3
            End If
            Exit For
        End If
        lngByte = lngByte3
    Next IX
    ' 桁不足判定(空白文字追加)
    If lngByte < lngFixBytes Then
        strOutText = strOutText & Space(lngFixBytes - lngByte)
    End If
    FP_GET_FIXLNG = strOutText
End Function