SJIS固定長 複数定義 タブ区切り化

＜変形元＞
固定長SJISテキストデータにCrLfを付加（VBScriptにて試行２　自給自足版）
http://blog.goo.ne.jp/tkhs1732/e/b73e022f14f014e468ea60cb0a859cae

＜FixedToTSV.vbs＞SJIS固定長区切るツール
Option Explicit
    Dim byteDat(255)
    Call  Make256
 
    Dim oExcel       'As Object
   
    Dim FileRead     'As String
    Dim FileWrite    'As String
   
    Dim strPathIN    'As String
    Dim strPathOUT   'As String
 
    Dim oADOST_R     'As Object
    Dim oADOST_W     'As Object
 
    Dim i            'As Long
   
    Dim readPos      'As Long ' or Currency or Double
    Dim SJIS_NUM     'As Integer
   
    Dim dthead1
    Dim dthead2
   
    Dim KBN
   
    '************レングスをセットしてください。 ****************
    SJIS_NUM = 150 + 2
    '***********************************************************
    'ReDim SJIS_buf(SJIS_NUM - 1 + 2)  '2=Crlf
   
    Set oExcel = CreateObject("Excel.Application")
    FileRead = oExcel.GetOpenFilename("インプット(*.*),*")
    FileWrite = oExcel.GetSaveAsFilename( _
          "FixedToTSV_Out.txt" _
       , "テキストファイル(*.txt),*.txt" & _
         ",その他のファイル(*.*),*.*" _
       , 1 _
       , "保存先の指定" _
       )
    oExcel.Quit
    Set oExcel = Nothing
 
    If UCase(FileRead) = "FALSE" Then
       MsgBox "入力ファイルの選択がキャンセルされました。" & vbLf & _
              "処理を終了します。"
       'Exit Sub
       WScript.Quit
    End If
 
    If UCase(FileWrite) = "FALSE" Then
       MsgBox "出力ファイルの選択がキャンセルされました。" & vbLf & _
              "処理を終了します。"
      'Exit Sub
      WScript.Quit
    End If
 
    strPathIN  = FileRead
    strPathOUT = FileWrite
 
    '読込Object設定
    Set oADOST_R = CreateObject("ADODB.Stream")
 
    oADOST_R.Type = 1   '1=adTypeBinary 2=adTypeText
    oADOST_R.Open
    oADOST_R.LoadFromFile strPathIN
    readPos = 0
    oADOST_R.Position = readPos '読込開始位置
 
      'dat_CrLf = oADOST_R.Read(2)
 
    '書込Object設定
    Set oADOST_W = CreateObject("ADODB.Stream")
 
    oADOST_W.Type = 1 '1=adTypeBinary 2=adTypeText
    'oADOST_W.Charset = "iso-8859-1" 'キャラクタセット＝Latin-1
    oADOST_W.Open
   
      'readPos = 2                 'CrLf分進める
      'oADOST_R.Position = readPos '読込開始位置
 
    Do Until oADOST_R.EOS = True
       'dthead1 = UCase(Right("0" & Hex(AscB(oADOST_R.Read(1))) , 2 ))
       'dthead2 = UCase(Right("0" & Hex(AscB(oADOST_R.Read(1))) , 2 ))
       dthead1 = Chr(AscB(oADOST_R.Read(1)))
       dthead2 = Chr(AscB(oADOST_R.Read(1)))
       KBN = dthead1 & dthead2

       oADOST_R.Position = readPos
       If     KBN = "00" Then
             Call KBN00
       ElseIf KBN = "01" Then
             Call KBN01
       ElseIf KBN = "02" Then
             Call KBN02     
       ElseIf KBN = "03" Then
             Call KBN03
       ElseIf KBN = "99" Then
             Call KBN99
       End If
      
       oADOST_W.Write byteDat(&H0D)
       oADOST_W.Write byteDat(&H0A)
     
       readPos = readPos + SJIS_NUM
       oADOST_R.Position = readPos
    Loop
   
    '既にファイルが存在する場合　1=実行時エラー、2=上書保存
    oADOST_W.SaveToFile strPathOUT, 2
   
    oADOST_R.Close
    oADOST_W.Close
    Set oADOST_R = Nothing
    Set oADOST_W = Nothing
   
    MsgBox "処理終了"
 
Function Make256()
    Dim oADOST_W256  'As Object
    Dim oADOST_R256  'As Object
    Dim i            'As Long
    Dim readPos
    Dim oFS          'As Object
    '書込Object設定
    Set oADOST_W256 = CreateObject("ADODB.Stream")
 
        oADOST_W256.Type = 2 'adTypeText
        oADOST_W256.Charset = "iso-8859-1" 'キャラクタセット＝Latin-1
        oADOST_W256.Open
   
        For i = 0 To 255
           oADOST_W256.WriteText ChrW(i)
        Next
   
        '既にファイルが存在する場合　1=実行時エラー、2=上書保存
        oADOST_W256.SaveToFile "byte256.tmp", 2
   
        oADOST_W256.Close
    Set oADOST_W256 = Nothing
 
    '読込Object設定
    Set oADOST_R256 = CreateObject("ADODB.Stream")
        oADOST_R256.Type = 1   '1=adTypeBinary 2=adTypeText
        oADOST_R256.Open
                             
        oADOST_R256.LoadFromFile "byte256.tmp"
 
        For readPos = 0 To 255
            oADOST_R256.Position = readPos '読込開始位置
            byteDat(readPos) = oADOST_R256.Read(1)
        Next
        oADOST_R256.Close
    Set oADOST_R256 = Nothing
 
    Set oFS = CreateObject("Scripting.FileSystemObject")
    oFS.DeleteFile("byte256.tmp")
    Set oFS = Nothing
End Function

Function     KBN00()
 oADOST_W.Write  oADOST_R.Read(002) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(006) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(142)
End Function

Function     KBN01()
 oADOST_W.Write  oADOST_R.Read(002) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(015) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(060) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(073)
End Function

Function     KBN02()
 oADOST_W.Write  oADOST_R.Read(002) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(015) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(010) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(008) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(115)
End Function

Function     KBN03()
 oADOST_W.Write  oADOST_R.Read(002) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(015) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(060) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(024) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(001) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(048)
End Function

Function     KBN99()
 oADOST_W.Write  oADOST_R.Read(002) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(009) : oADOST_W.Write  byteDat(&H09)
 oADOST_W.Write  oADOST_R.Read(139)
End Function

 

＜20131104追記始＞
①FixedToTabしたファイルを開いて、
　　Ctrl + a　、　Ctrl + c
②　Excel 開いて　貼り付け

固定長の種VBScript
　下記scriptを実行し、
　適当に半角2文字を全角１文字に置き換えて試す。項目境界＃はだめ。
＜Fixed_seed.vbs＞
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim TargetFile 'As String
    Dim oFS 'As Object
    Dim oFR 'As Object
    Dim oFW 'As Object
 
    Dim i 'As Long
    Dim out_area(4)
    Dim KBN

    Call Make_out
    TargetFile = "FIXED_SEED.txt"

     Set oFS = CreateObject("Scripting.FileSystemObject")

     Set oFW = oFS.OpenTextFile(TargetFile, ForWriting, True)

    For i = 1 To 400
        KBN = Int(Rnd()*5)
        'CrLf付き
        oFw.Writeline out_Area(KBN)
        'Crlf無し
        'oFw.Write out_Area(KBN)
    Next

     oFW.Close

     Set oFW = Nothing
    Set oFS = Nothing
    MsgBox "処理終了"

 Function     Make_out()
 out_area(0) =  "00"    & _
                String(005,"A") & "#" & _
                String(141,"B") & "#"
 out_area(1) =  "01"    & _
                String(014,"C") & "#" & _
                String(059,"D") & "#" & _
                String(072,"E") & "#"
 out_area(2) =  "02"    & _
                String(014,"F") & "#" & _
                String(009,"G") & "#" & _
                String(007,"H") & "#" & _
                String(114,"J") & "#"
 out_area(3) =  "03"    & _
                String(014,"K") & "#" & _
                String(059,"L") & "#" & _
                String(023,"M") & "#" & _
                String(001,"N") & _
                String(047,"P") & "#"
 out_area(4) =  "99"    & _
                String(008,"Q") & "#" & _
                String(138,"R") & "#"
End Function

＜20131104追記終＞

 

VBScriptでExcel関数を使う

 '＜WSFUNC1.vbs＞

set objExcel = CreateObject("Excel.Application")
set WSFUNC  = objExcel.WorksheetFunction

MsgBox WSFUNC.Ceiling(200, 19)

Dim myArray
   
    myArray = Array(Array("0", "A"), _
                    Array("1", "B"), _
                    Array("2", "C"), _
                    Array("3", "D"), _
                    Array("4", "E"), _
                    Array("5", "F"), _
                    Array("6", "G"), _
                    Array("7", "H"), _
                    Array("8", "I"), _
                    Array("9", "J"))
MsgBox WSFUNC.VLookup("5", myArray, 2, False)
   
set objExcel = Nothing
set WSFUNC   = Nothing

 ＜20120611発見＞

http://memoofwork.seesaa.net/

    WSHで.NETFrameworkを使用してソートするには
    http://memoofwork.seesaa.net/article/16426580.html

 

＜20180730追記STA＞WorkSheetFunctionワークシート関数

使えそうな関数の調べ方

Sub WSFunc_aaa()
    Dim WSFunc  As WorksheetFunction
    Set WSFunc = Application.WorksheetFunction
    WSFunc  '＜＝「.」を入れるとでてくる

End Sub

＜20180730追記END＞

Excelシート全部をA1（左上隅）に寄せる vbs

Excelシート全部をA1（左上隅）に寄せる

「Office TANAKA」様
ワークシートをスクロールする
http://officetanaka.net/excel/vba/tips/tips79.htm

＜その１＞SheetA1LeftUp1.vbs
Option Explicit

Dim myPath
Dim myExcel
Dim WS
Dim shVisible
Dim TargetFile

Dim objExcel
Dim objFS
Dim objFile

Set objExcel = CreateObject("Excel.Application")
Set objFS    = CreateObject("Scripting.FileSystemObject")
Set objFile  = objFS.GetFile("SheetA1LeftUp1.vbs")

myPath  = objFile.ParentFolder
myExcel = InputBox("Excelファイルを選択", _
                   "Excelファイルを選択してください。",  _
                   "　ＥＸＣＥＬファイル指定.xls")

TargetFile = myPath & "\" & myExcel

If objFS.FileExists(TargetFile) = True Then

   objExcel.Visible = True
   objExcel.WorkBooks.Open TargetFile
  
   objExcel.Application.ScreenUpdating = False
  
   For Each WS In objExcel.Sheets

      shVisible = WS.Visible
     
      WS.Visible = True
     
      WS.Select
     
      objExcel.ActiveSheet.Range("A1").Select
     
      objExcel.ActiveWindow.ScrollRow    = 1
      objExcel.ActiveWindow.ScrollColumn = 1

      WS.Visible = shVisible
   Next
  
   objExcel.Sheets.Item(1).Select
   objExcel.ActiveSheet.Range("A1").Select
   objExcel.ActiveWorkBook.Save
  
   objExcel.Application.ScreenUpdating = True
  
   objExcel.ActiveWorkBook.Close
Else
   MsgBox "Excelファイルが選択されませんでした。"
End If

objExcel.Quit

Set objExcel = Nothing
Set objFS    = Nothing
Set objFile  = Nothing

 

＜その２＞SheetA1LeftUp2.vbs
Option Explicit

Dim myPath
Dim myExcel
Dim WS
Dim shVisible
Dim TargetFile

Dim objExcel

Set objExcel = CreateObject("Excel.Application")

TargetFile = objExcel.GetOpenFileName("Excelファイル (*.xls),*.xls")

If TargetFile <> "False" Then

   objExcel.Visible = True
   objExcel.WorkBooks.Open TargetFile
  
   objExcel.Application.ScreenUpdating = False
  
   For Each WS In objExcel.Sheets

      shVisible = WS.Visible
     
      WS.Visible = True
     
      WS.Select
     
      objExcel.ActiveSheet.Range("A1").Select
     
      objExcel.ActiveWindow.ScrollRow    = 1
      objExcel.ActiveWindow.ScrollColumn = 1

      WS.Visible = shVisible
   Next
  
   objExcel.Sheets.Item(1).Select
   objExcel.ActiveSheet.Range("A1").Select
   objExcel.ActiveWorkBook.Save
  
   objExcel.Application.ScreenUpdating = True
  
   objExcel.ActiveWorkBook.Close
Else
   MsgBox "Excelファイルが選択されませんでした。"
End If

objExcel.Quit

Set objExcel = Nothing

便利 ADO でSORT

便利 ADO でSORT
　　　　　　CSVとかのテキストデータ系ソートサンプルです（複数キー３キー）。ADODB.Recordset使用。
　　　　　　ADODB.Connectionは、使いません。

＜ファイル入出力で使用させていただいたソース＞
  VBSでのファイル入出力
  http://chaichan.lolipop.jp/vbtips/VBMemo2006081801.htm

＜ADO操作で参考にさせていただいたソース＞
  レコードセットの作成（ADO編）
  http://www.geocities.jp/cbc_vbnet/ADO/append.html

  CSVファイルをVBSを使用して日付でソートする方法をご教授下さい。 ソートしたい
  http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1460157904

  ADO定数
  http://tuka.s12.xrea.com/index.xcg?p=ADO%C4%EA%BF%F4

  その他　多数（控えておくのを忘れました）

2012年01月31日記事
VBScript で　昇降順混じりSortKey作って DOSでSORT
http://blog.goo.ne.jp/tkhs1732/e/4157473e89bf05f390738ae5b638bff3
"データ.csv" 使用

＜ADODB_SORT.vbs＞
Option Explicit
WScript.Echo "TEST開始"
If TestFileCopy = 0 then
    WScript.Echo "コピー正常"
Else
    WScript.Echo "コピー異常"
End if
WScript.Echo "TEST終了"
WScript.Quit(0)

Function TestFileCopy()
'----------------------------------------------------
'TEST testIn.csv copy to testOut.csv
'----------------------------------------------------
const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim strPathIn
Dim strPathOut
Dim fs, fr, fw
Dim intSts

Const adDate = 7
Const adCurrency = 6
Const adVarChar = 200
Dim rs

Dim i

Dim myCSV
Dim myStr1
Dim myStr2
Dim myStr3
Dim myCur

    Set rs = CreateObject("ADODB.Recordset")
    strPathIn = "データ.csv"
    strPathOut = "データ_ADODB_OUT.csv"
    Set fs = CreateObject("Scripting.FileSystemObject")

    rs.Fields.Append "KEY-A",  adVarChar, 2
    rs.Fields.Append "KEY-B",  adVarChar, 1
    rs.Fields.Append "KEY-C",  adCurrency
    rs.Fields.Append "File_Data",  adVarChar, 500
    rs.Open

    If fs.fileexists(strPathIn) then
        Set fr = fs.OpenTextFile(strPathIn, ForReading)
        Set fw = fs.OpenTextFile(strPathOut, ForWriting,True)

        Do While Not fr.AtEndOfStream
            myStr1 = fr.ReadLine
            If myStr1 = Chr(&H0D0A) then
            Else
              myCSV  =  Split(myStr1,",")

              'myCur  =  100000000000000 - CCur(myCSV(4))
              'myStr2 =  Right("00000000000000" & CStr(myCur),15)
              'If      myCSV(1) = "X" Then
              '    myStr3 = "C"
              'Elseif  myCSV(1) = "Y" Then
              '    myStr3 = "B"
              'Elseif  myCSV(1) = "Z" Then
              '    myStr3 = "A"
              'Else
              '    myStr3 = "D"
              'End If

              rs.AddNew
              rs.Fields("KEY-A").Value = myCSV(0)
              rs.Fields("KEY-B").Value = myCSV(1)
              rs.Fields("KEY-C").Value = CCur(myCSV(4))
              rs.Fields("File_Data").Value = myStr1
            End If
        Loop

        rs.Sort = "KEY-A  ASC, KEY-B DESC, KEY-C DESC"
        rs.MoveFirst
       
        Do While Not rs.EOF     
           fw.WriteLine  rs.Fields("File_Data").Value
           rs.MoveNext
        Loop
       
        fw.Close
        fr.Close
        Set fw = Nothing
        Set fr = Nothing
        intSts = 0
    Else
        Call MsgBox("ファイル見つからない！",48,"エラー")
        intSts = 1
    End if

    Set fs = Nothing
    Set rs = Nothing
    TestFileCopy = intSts
End Function

＜20180715追記STA＞

Const adDate = 7
Const adCurrency = 6
Const adVarChar = 200

上記は、（項目の型）のセットをわかりやすくするためのもの

 

ADO定数
http://tuka.s12.xrea.com/index.xcg?p=ADO%C4%EA%BF%F4　とか　MSで調べる

C:\Program Files\Common Files\System\ado
　　adojavas.inc　＜＝JScript用
　　adovbs.inc　　＜＝VBScript用
の中身見るとか（これはVISTAなので、上位OSは変ってるかも）

 

rs.Fields.Append "KEY-A", adVarChar, 2 ＜＝２文字
rs.Fields.Append "KEY-B", adVarChar, 1 ＜＝１文字
rs.Fields.Append "KEY-C", adCurrency ＜＝数値型 この場合Currency型の範囲で
rs.Fields.Append "File_Data", adVarChar, 500 ＜＝５００文字

 

ソート　インプットデータ種
500文字以内になるようにしてます。

＜makeData.vbs＞
  Dim myData(5)
  Const ForReading = 1, ForWriting = 2, ForAppending = 8
  Dim strPathIn
  Dim strPathOut
  Dim oFS, oFR, oFW
 
    'strPathIn = "データ.csv"
    strPathOut = "データ.csv"

    Set oFS = CreateObject("Scripting.FileSystemObject")

    'Set oFR = oFS.OpenTextFile(strPathIn, ForReading)
    Set oFW = oFS.OpenTextFile(strPathOut, ForWriting,True)

 

  Randomize()
    For i = 1 To  70000
      myData(0) = CHR(INT(RND()*10+65)) & CHR(INT(RND()*10+65))
      myData(1) = CHR(90-INT(RND()*3))

      a01 = ""
      IF (INT(RND()*2)=1) Then
        a01 = "-"
      Else
        a01 = ""
      End If 
      myData(2) = a01 & INT(RND()*100000000000000)

      a02 = ""
      IF (INT(RND()*2)=1) Then
        a02 = "-"
      Else
        a02 = ""
      End If 
      myData(3) = a02 & INT(RND()*100000000000000)

      a03 = ""
      IF (INT(RND()*2)=1) Then
        a03 = "-"
      Else
        a03 = ""
      End If 
      myData(4) = a03 & INT(RND()*100000000000000)

      myData(5) = String(400,CHR(INT(RND()*26+65)))

      'oFW.WriteLine  Join(myData,vbTab)
      oFW.WriteLine  Join(myData,",")

    Next

    oFW.Close
    'oFR.Close
    Set oFW = Nothing
    'Set oFR = Nothing
    MsgBox "処理終了"
＜20180715追記END＞

VBScript でファイル選択ダイアログ＜参考記事＞

VBScript でファイル選択ダイアログ 参考記事

「ある nakagami の日記」様
http://nakagami.blog.so-net.ne.jp/
    ファイルダイアログの記事↓
    http://nakagami.blog.so-net.ne.jp/2008-12-08
   
Excelがあれば、Excelから
    GetOpenFilename
    GetSaveAsFileName
を呼び出せるこがとわかった
（XPでEXCEL2002,2003しか試していない）。

2012/01/05 Vista HomePremium Excel2007でも動きました。

＜以下VBScript＞

set objExcel = CreateObject("Excel.Application")
'set objBook  = objExcel.WorkBooks.Add
'objExcel.Visible = True

    TargetFile1 = objExcel.GetOpenFilename("読込み (*.*),*")
    MsgBox ("TargetFile1=" & TargetFile1)
   
    TargetFile2 = objExcel.GetSaveAsFileName(   _
                  "TEST_AAA"                    _
                 ,"テキスト文書(*.txt),*.txt" & _
                  ",CSVファイル(*.csv),*.csv" & _
                  ",その他ファイル(*.*),*.*"    _
                 ,1                             _
                 ,"保存先の指定"                _
                 )
    MsgBox ("TargetFile2=" & TargetFile2)

    '2012/01/05 STA
    'Excelのゾンビタスク予防に入れておいたほうが良いみたい
    objExcel.Quit
    '2012/01/05 END

set objExcel = Nothing
'set objBook  = Nothing

 

 

＜20140119STA＞
通常はこちらのほうがいいとおもいます。

 

 WSH JScriptを使いこなそう ～情報の入力方法～
http://3rd.geocities.jp/kaito_extra/Source/InputInfo.html

 

 注意すべき変更箇所のみ
「ファイル選択ダイアログボックス」
１．Set oFOP = CreateObject( "UserAccounts.CommonDialog" )
２．oFOP.Flags = OFN_FILEMUSTEXIST or OFN_HIDEREADONLY
３．If( CBool(rtn)  =  false ) Then　と　End If

 

 「ファイル保存ダイアログボックス」
ファイル選択ダイアログボックスと同様
１．//  初期表示のディレクトリパスを設定
　　oFSV.FileName = "C:\*.txt"

 

 ＜20140119END＞

VBScript でファイル選択ダイアログ２

http://blog.goo.ne.jp/tkhs1732/e/1459e16e41d25709803e942499d62a9d