【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