Top / TIPS / VB でコンソールプログラム

リンカで exe を書き換える

VB6.0 では API を使っても、標準入出力が扱えません。*1
ですので、作成した exe をリンカで書き換える必要があります。

   link /edit /subsystem:console (作成した exe名)

コーディング例

API を使う方法

プログラムでは、GetStdHandle で得たハンドルに対し、ReadFile/WriteFile*2で読み書きを行います。

   Option Explicit
   
   Private Const STD_ERROR_HANDLE  As Long = -12&
   Private Const STD_INPUT_HANDLE  As Long = -10&
   Private Const STD_OUTPUT_HANDLE As Long = -11&
   Private Const ERROR_BROKEN_PIPE As Long = 109
   
   Private Declare Function GetStdHandle _
                   Lib "kernel32" ( _
                   ByVal nStdHandle As Long _
                   ) As Long
   
   Private Declare Function WriteFile _
                   Lib "kernel32" ( _
                   ByVal hFile As Long, _
                   lpBuffer As Any, _
                   ByVal nNumberOfBytesToWrite As Long, _
                   lpNumberOfBytesWritten As Long, _
                   ByVal lpOverlapped As Long _
                   ) As Long
   
   Private Declare Function ReadFile _
                   Lib "kernel32" ( _
                   ByVal hFile As Long, _
                   lpBuffer As Any, _
                   ByVal nNumberOfBytesToRead As Long, _
                   lpNumberOfBytesRead As Long, _
                   ByVal lpOverlapped As Long) As Long
   
   Private Const EOF_CODE As Long = &H1A
   
   Sub Main()
       Dim buf As String
       Do
           buf = InputLine
           If buf = Chr(EOF_CODE) Then Exit Do
           PrintLine buf
           If LCase(buf) = "end" Then Exit Do
       Loop
   End Sub
   
   Public Function InputLine() As String
       Dim hStdIn      As Long
       Dim nRet        As Long
       Dim nReadByte   As Long
       Dim bytChars()  As Byte
       Dim outBuff     As String
       Dim strChar     As String
       
       Static Buffer   As String
       
       Do
           ' バッファが空になるまでは読み込んだ内容から vbCr で区切って値を返す
           
           Do Until Len(Buffer) = 0
               
               strChar = Left(Buffer, 1)
               Buffer = Mid(Buffer, 2)
               
               Select Case strChar
                   Case vbCr
                       InputLine = outBuff
                       Exit Function
                       
                   Case vbLf
                       ' 読み捨て
                   
                   Case Chr(EOF_CODE)
                       If Len(outBuff) > 0 Then
                           InputLine = outBuff
                           Buffer = Chr(EOF_CODE) ' 次の回でEOF
                           Exit Function
                       Else
                           InputLine = Chr(EOF_CODE)
                           Exit Function
                       End If
                   
                   Case Else
                       outBuff = outBuff & strChar
               End Select
           Loop
       
           hStdIn = GetStdHandle(STD_INPUT_HANDLE)
       
           ' 指定したバイト数に漢字の1バイト目がくる場合
           ' ReadFile は1バイト余分に読み込むようです。
           ' バッファは1バイト余分に確保してください。

           ReDim bytChars(1024)
           nRet = ReadFile(hStdIn, bytChars(0), _
                           1024, nReadByte, 0)
           If nRet = 0 Then
               Select Case Err.LastDllError
                   Case ERROR_BROKEN_PIPE
                   Case Else
                       Err.Raise Err.LastDllError
               End Select
           End If
           If nReadByte > 0 Then
               ReDim Preserve bytChars(nReadByte - 1)
               Buffer = Buffer & StrConv(bytChars, vbUnicode)
           Else
               Buffer = Buffer & Chr(EOF_CODE)
           End If
       Loop
           
   End Function
   
   Public Sub PrintLine(ByVal Buffer As String)
       Dim bytBuff()   As Byte
       Dim hStdOut     As Long
       Dim nBytes      As Long
       Dim nWriteByte  As Long
       Dim nPos        As Long
       Dim nRet        As Long
       
       hStdOut = GetStdHandle(STD_OUTPUT_HANDLE)
       
       bytBuff = StrConv(Buffer & vbCrLf, vbFromUnicode)
       nBytes = UBound(bytBuff) - LBound(bytBuff) + 1
       nPos = 0
       
       Do Until nBytes = 0
           
           nRet = WriteFile(hStdOut, bytBuff(nPos), _
                                   nBytes, nWriteByte, 0)
           If nRet = 0 Then Err.Raise Err.LastDllError
           
           nPos = nPos + nWriteByte
           nBytes = nBytes - nWriteByte
       
       Loop
   
   End Sub

Scripting.FileSystemObject を使用する方法

Microsoft Scripting Runtime を参照設定してください。

   Option Explicit
   
   Sub Main()
       
       Dim fso As Scripting.FileSystemObject
       Dim O As Scripting.TextStream
       Dim I As Scripting.TextStream
       Dim buf As String
       
       Set fso = New Scripting.FileSystemObject
       Set O = fso.GetStandardStream(StdOut, False)
       Set I = fso.GetStandardStream(StdIn, False)
       
       Do Until I.AtEndOfStream
           buf = I.ReadLine
           O.WriteLine buf
           If LCase(buf) = "end" Then Exit Do
       Loop
       
       O.Close
       I.Close
   
   End Sub


*1 標準出力は行えますが、コマンドプロンプトに表示されません。また、AllocConsole で別コンソールを開けば使えます。
*2 ReadConsole/WriteConsole を使うと処理が楽ですが、ファイルをリダイレクトしたとき不具合が出るようです。

トップ   編集 凍結 差分 バックアップ 添付 複製 名前変更 リロード   新規 一覧 単語検索 最終更新   最終更新のRSS
Last-modified: 2009-11-29 (日) 03:19:04 (2766d)