Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


76340 / 76732 ←次へ | 前へ→

【4814】Re:テキストファイルへのパッチについて
回答  Hirofumi E-MAIL  - 03/4/8(火) 20:44 -

引用なし
パスワード
   こんな方法も有ります
始めて作ったので上手く行くかな?
置換するファイルを別名でCopyして、そのファイルを処理しています
置換する、文字列、位置等はワークシートから読み込んでいます
読みこむシートの構成は、
Sheet1にに設定しています
Sheet1のA2に1レコードの総バイト数(改行コード分も含む)
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")
    '1レコードの総バイト数(改行コードも含む)を取得
    lngRecLen = Val(.Cells(2, 1).Value)
    '置換位置、長さ、文字列を取得
    vntRepl = Range(.Cells(4, 1), _
          .Cells(65536, 3).End(xlUp)).Value
  End With
  '1レコードの置換数を取得
  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が長い場合、2バイト文字の処理を行います
  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
0 hits

【4782】テキストファイルへのパッチについて あつし 03/4/7(月) 13:12 質問
【4796】Re:テキストファイルへのパッチについて こうちゃん 03/4/8(火) 9:12 発言
【4805】Re:テキストファイルへのパッチについて あつし 03/4/8(火) 13:15 お礼
【4797】Re:テキストファイルへのパッチについて ポンタ 03/4/8(火) 9:31 回答
【4820】Re:テキストファイルへのパッチについて あつし 03/4/9(水) 0:23 質問
【4822】Re:テキストファイルへのパッチについて ポンタ 03/4/9(水) 8:26 回答
【4863】Re:テキストファイルへのパッチについて あつし 03/4/11(金) 0:53 お礼
【4814】Re:テキストファイルへのパッチについて Hirofumi 03/4/8(火) 20:44 回答
【4821】Re:テキストファイルへのパッチについて あつし 03/4/9(水) 0:26 発言
【4864】Re:テキストファイルへのパッチについて あつし 03/4/11(金) 1:03 お礼

76340 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free