| |
こんな方法も有ります
始めて作ったので上手く行くかな？
置換するファイルを別名でCopyして、そのファイルを処理しています
置換する、文字列、位置等はワークシートから読み込んでいます
読みこむシートの構成は、
Sheet1にに設定しています
Sheet1のA2に１レコードの総バイト数（改行コード分も含む）
Sheet1のA烈のA4かA5、A6と言う様に置換するレコードの位置を
Sheet1のB烈のB4かB5、B6と言う様に置換するバイト数を
Sheet1のC烈のC4かC5、C6と言う様に置換する文字列を
書き込みます
A B C
1
2 160
3
4 1 12 トウキョウト
5 20 12 東京都
6
尚、このコードは1レコードづつ読み込んで処理はしていません
直接、ファイルの指定位置に指定バイト数を書き込んでいます
以下のコードを標準モジュールに記述
Option Explicit
Public Sub SDFReplace()
Dim i As Long
Dim j As Long
Dim vntInFile As Variant
Dim strOutFile As String
Dim dfn As Integer
Dim lngRecLen As Long
Dim vntRepl As Variant
Dim lngReplMax As Long
Dim bytBuff() As Byte
'置換元のファイルを選択
vntInFile = Application.GetOpenFilename("Textファイル (*.txt), *.txt")
If vntInFile = False Then
Exit Sub
End If
'もし置換元のファイルにデータが無い場合
If FileLen(CStr(vntInFile)) = 0 Then
Exit Sub
End If
'置換元ファイル名から置換先ファイル名を作成
strOutFile = Left(vntInFile, InStr(1, vntInFile, _
".", vbBinaryCompare) - 1)
strOutFile = strOutFile & "New" & Mid(vntInFile, _
InStr(1, vntInFile, ".", vbBinaryCompare))
'もし、置換先ファイルが有る場合それを削除
If Dir(strOutFile) <> "" Then
Kill strOutFile
End If
'置換元を置換先名にしてコピー
FileCopy vntInFile, strOutFile
'Sheet1から総バイト数、置換位置、長さ、文字列を取得
With Worksheets("Sheet1")
'１レコードの総バイト数（改行コードも含む）を取得
lngRecLen = Val(.Cells(2, 1).Value)
'置換位置、長さ、文字列を取得
vntRepl = Range(.Cells(4, 1), _
.Cells(65536, 3).End(xlUp)).Value
End With
'１レコードの置換数を取得
lngReplMax = UBound(vntRepl, 1)
'置換文字列をユニコードから変換してフィール長に調整
For i = 1 To lngReplMax
vntRepl(i, 3) = FieldString(vntRepl(i, 2), vntRepl(i, 3))
Next i
'置換先ファイルをBinaryモードでOpen
dfn = FreeFile
Open strOutFile For Binary As dfn
'第一レコードから最終レコードまで繰り返し
For i = 1 To LOF(dfn) \ lngRecLen
'置換数まで繰り返し
For j = 1 To lngReplMax
'置換文字列をByte配列に格納
bytBuff = vntRepl(j, 3)
'置換位置に出力
Put #dfn, vntRepl(j, 1) + lngRecLen * (i - 1), bytBuff
Next j
Next i
'ファイルを閉じる
Close dfn
End Sub
Public Function FieldString(ByVal lngLength As Long, _
ByVal strData As String, _
Optional strAlign As String = "L") As String
' Dataをフィールド長に調整
'lngLengthはフィールドの長さを半角何文字分（バイト単位）で
'strDataはデータを文字列の型で
'strAlignは左詰なら"L"で（デホルトは"L"）、
'右詰なら"R"で（実際は、"L","l"以外なら可）
Dim strSpace As String
Dim i As Long
Dim intCode As Integer
'文字列を Unicode からシステムの既定のコード ページに置換します
strData = StrConv(strData, vbFromUnicode)
'フィールド長よりDataが長い場合、２バイト文字の処理を行います
If LenB(strData) > lngLength Then
strData = LeftB(strData, lngLength)
intCode = Asc(Right$(StrConv(strData, vbUnicode), 1))
If (0 <= intCode And intCode <= 7) _
Or (11 <= intCode And intCode <= 12) _
Or (14 <= intCode And intCode <= 31) _
Or (127 <= intCode And intCode <= 159) _
Or (224 <= intCode And intCode <= 255) Then
strData = LeftB(strData, lngLength - 1)
End If
End If
'長さ調整用のスペースを作成します
If lngLength > LenB(strData) Then
strSpace = StrConv(Space$(lngLength - LenB(strData)), _
vbFromUnicode)
'Dataをフィールド長に調整します
If strAlign = "L" Or strAlign = "l" Then
strData = strData & strSpace
Else
strData = strSpace & strData
End If
End If
FieldString = strData
End Function
|
|
- 03/4/8(火) 9:12 -
