ファイル入出力に関するサンプル（シーケンシャルファイル編)
　
　 　

サンプル１：ファイルへの書き込み (Output)、Write ステートメント使用

  • ファイルが存在しない場合は新規に作成します。
  • データ項目の間にカンマを挿入します。
  • 文字列はダブルクォーテションで出力します。
  • 最後の文字を出力した時に改行文字を挿入します。
  • データの追加は行わず常に上書きします。 
  Sub Text_Output_Write()
      Dim MyInteger As Integer
      Dim MyString As String * 10
      Dim DataNumber As Integer
      Dim FileNumber As Long
      FileNumber = FreeFile
      Open "c:\temp\TextWrite.txt" For Output Access Write As #FileNumber

      For DataNumber = 1 To 5
          MyInteger = DataNumber
          MyString = "TextWrite" & DataNumber
          Write #FileNumber, MyInteger, MyString
      Next DataNumber

      Close #FileNumber
  End Sub

サンプル２：ファイルへの書き込み (Output)、Print ステートメント使用

  • ファイルが存在しない場合は新規に作成します。
  • 最後の文字を出力した時に改行文字を挿入します。
  • データの追加は行わず常に上書きします。 
  Sub Text_Output_Print()
      Dim MyInteger As Integer
      Dim MyString As String * 10
      Dim DataNumber As Integer
      Dim FileNumber As Long
      FileNumber = FreeFile

      Open "c:\temp\TextPrint.txt" For Output Access Write As #FileNumber

      For DataNumber = 1 To 5
          MyInteger = DataNumber
          MyString = "TextWrite" & DataNumber
          Print #FileNumber, Spc(2); "No."; MyInteger; Tab; "Data:"; MyString
      Next DataNumber

      Close #FileNumber
  End Sub

サンプル３：ファイルへの書き込み (Append)　

  • ファイルが存在しない場合は新規に作成します。
  • データを最後に追加します。
    （サンプル２ で作成されたファイルを使用します。） 
  Sub Text_Append_Print()
      Dim MyInteger As Integer
      Dim MyString As String * 10
      Dim DataNumber As Integer
      Dim FileNumber As Long
      FileNumber = FreeFile

      Open "c:\temp\TextPrint.txt" For Append Access Write As #FileNumber

      For DataNumber = 1 To 5
          MyInteger = DataNumber
          MyString = "TextWrite" & DataNumber
          Print #FileNumber, Spc(2); "No."; MyInteger; Tab; "Data:"; MyString
      Next DataNumber

      Close #FileNumber
  End Sub

サンプル４：データの読み込み (Input)、Input ステートメント使用

  • レコード単位で読み込みます。(カンマ区切り) （サンプル１ で作成されたファイルを使用します。） 
  Sub Text_Input_Input()
      Dim MyInteger() As Integer
      Dim MyString() As String
      Dim DataNumber As Integer
      Dim FileNumber As Long
      FileNumber = FreeFile

      Open "c:\temp\TextWrite.txt" For Input Access Read As #FileNumber

      DataNumber = 0
      Do While Not EOF(FileNumber) ' ファイルの最後までループを繰り返します
          DataNumber = DataNumber + 1
          ReDim Preserve MyInteger(DataNumber)
          ReDim Preserve MyString(DataNumber)
          Input #FileNumber, MyInteger(DataNumber), MyString(DataNumber)
      Loop
      For DataNumber = 1 To UBound(MyInteger)
       MsgBox MyInteger(DataNumber) & Chr$(13) & Chr$(10) & MyString(DataNumber)
      Next DataNumber

      Close #FileNumber
  End Sub

サンプル５：データの読み込み (Input)、Line Input ステートメント使用

  • レコード単位で読み込みます。(レコード全体） (サンプル１ で作成されたファイルを使用します。) 
  Sub Text_Input_lineInput()
    Dim FileNumber As Long
    Dim TextLine As String
    FileNumber = FreeFile
    Open "c:\temp\TextWrite.txt" For Input Access Read As #FileNumber
    Do While Not EOF(FileNumber)
        Line Input #FileNumber, TextLine
    Loop
    Close #FileNumber
  End Sub

サンプル６：データの読み込み (Input)、Input 関数使用

  • カンマ、キャリッジリターン (Chr(13))、ラインフィード (Chr(10))、ダブルクォーテーション、
    先頭のスペースも読み込みます。
    （サンプル１ で作成されたファイルを使用します。） 
  Sub Text_Input_InputFunc()
      Dim Temp As String
      Dim MyInteger() As String
      Dim MyString() As String
      Dim DataNumber As Integer
      Dim FileNumber As Long
      FileNumber = FreeFile

      Open "c:\temp\TextWrite.txt" For Input Access Read As #FileNumber

      DataNumber = 0
      Do While Not EOF(FileNumber )         'ファイルの最後までループを繰り返します
          DataNumber = DataNumber + 1
          ReDim Preserve MyInteger(DataNumber)
          ReDim Preserve MyString(DataNumber)
          MyInteger(DataNumber) = Input(1, #FileNumber)
          Temp = Input(1, #FileNumber)     'カンマの読み込み
          MyString(DataNumber) = Input(12, #FileNumber)
          Temp = Input(2, #FileNumber)     'CRLF の読み込み
      Loop
      For DataNumber = 1 To UBound(MyInteger)
       MsgBox MyInteger(DataNumber) & Chr$(13) & Chr$(10) & MyString(DataNumber)
      Next DataNumber

      Close #FileNumber
  End Sub

番外編
Microsoft ActiveX Data Objectを参照設定
Sub ReadFile() 
Dim st As ADODB.Stream 
Dim rowNo As Integer 
On Error GoTo Err 
'ADODB.Stream生成 
Set st = New ADODB.Stream 
'Textモード 
st.Type = adTypeText 
'文字コード（Shift_JIS, Unicodeなど） 
st.Charset = "UTF-8" 
'Streamのオープン 
st.Open 
'ファイル読み込み 
st.LoadFromFile ("C:\test2.csv") 
rowNo = 1 
'ファイルの終りまでループ 
Do While Not (st.EOS) 
    '1行読み込み（readText(adReadAll)：すべて読み込み） 
    Worksheets("Sheet1").Cells(rowNo, 1).Value = st.ReadText(adReadLine) 
    rowNo = rowNo + 1 
Loop 
'クローズ 
st.Close 
Set st = Nothing 
Exit Sub 
Err: 
Set st = Nothing 
'エラー内容 
MsgBox (Err.Description) 
End Sub 

番外編
    On Error Resume Next
    FileNumber1 = FreeFile
    Open "c:\in.txt" For Binary Access Read As #FileNumber1
    If Err.Number <> 0 Then GoTo ErrExit
    On Error Resume Next
    FileNumber2 = FreeFile
    Open "c:\out.txt" For Output As #FileNumber2
    If Err.Number <> 0 Then GoTo ErrExit
    Do While Not EOF(FileNumber1)
        strText = Space(100)
        Get #FileNumber1, , strText
        Print #FileNumber2, strText
    Loop
    Close #FileNumber1
    Close #FileNumber2

番外編
Function getText()
Dim strR_DIR As String
Dim objF_SYS As Object
Dim objR_TEXT As Object
Dim strR_FILE As String
Dim strD As String
Dim lonCNT As Long
Dim lonDCNT As Long
Dim strCSV(1000) As String
Dim i As Long
Dim strTXT_NAME As String
    Set objF_SYS = CreateObject("Scripting.FileSystemObject")
    strTXT_NAME = "*取扱件数データ*.CSV"
    strR_DIR = "d:\down\"
    With Application.FileSearch
        .NewSearch
        .LookIn = strR_DIR
        .FileName = strTXT_NAME
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                strCSV(i) = .FoundFiles(i)
            Next i
        End If
        lonDCNT = .FoundFiles.Count
    End With
    For i = 1 To lonDCNT
        strR_FILE = strCSV(i)
        Set objR_TEXT = objF_SYS.OpenTextFile(strR_FILE)
        lonCNT = 0
        Do Until objR_TEXT.atendofline = True
            strD = objR_TEXT.ReadLine
            lonCNT = lonCNT + 1
        Loop
        MsgBox lonCNT
    Next i
    Set objR_TEXT = Nothing
    Set objF_SYS = Nothing
End Function

番外編
Dim i As Long
Dim strRec(8, 11) As String
Function getText() As Boolean
Dim objF_SYS As Object
Dim objR_TEXT As Object
Dim strR_FILE As String
Dim strD_FILE As String
Dim lonCNT As Long
Dim strTXT_NAME As String
Dim varArrayS As Variant    'テキスト開始位置
Dim varArrayL As Variant    'テキストレングス
    getText = True
    varArrayS = Array(, 1, 4, 11, 18, 25, 32, 39, 46, 53, 60, 67)
    varArrayL = Array(, 2, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6)
    Set objF_SYS = CreateObject("Scripting.FileSystemObject")
    strR_FILE = "\\xxx\xxx.txt"
    If Dir(strR_FILE) = "" Then
        MsgBox "テキストファイルが存在しません。" & vbCrLf & "xxx.txt"
        getText = False
        Set objF_SYS = Nothing
        Exit Function
    End If
    Set objR_TEXT = objF_SYS.OpenTextFile(strR_FILE)
    lonCNT = 1
    Do Until objR_TEXT.atendofline = True
        strD_FILE = objR_TEXT.ReadLine
        For i = 1 To UBound(varArrayS)
            strRec(lonCNT, i) = Mid(strD_FILE, varArrayS(i), varArrayL(i))
        Next i
        lonCNT = lonCNT + 1
    Loop
    If lonCNT = 1 Then
        MsgBox = "データが存在しません。" & vbCrLf & "xxx.txt"
        getText = False
    End If
    Set objR_TEXT = Nothing
    Set objF_SYS = Nothing
End Function

番外編　カンマ区切り
Sub test()
Dim i As Long
Dim lonFile As Long
Dim strText As String
Dim strFile As String
strFile = "C:\ak\down\aaa.csv"
lonFile = FreeFile
Open strFile For Input As #lonFile
i = 1
Do While Not EOF(lonFile)
    Line Input #lonFile, strText
    Sheets(1).Cells(i, 1) = strText
    Sheets(1).Cells(i, 1).Select
    Selection.TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=True, Comma:=True
    i = i + 1
Loop
Close #lonFile
End Sub

番外編　カンマ区切り
Sub import()
Dim i As Long
Dim j As Long
Dim lonFile As Long
Dim strFile As String
Dim ranPos As Range
Dim ranTmp As Range
Dim strText As String
strFile = "C:\ak\down\aaa.csv"
Worksheets(1).Activate
Range("A1").CurrentRegion.Select
Selection.Clear
Set ranPos = Range("A1")
lonFile = FreeFile
Open strFile For Input As #lonFile
i = 0
Do Until EOF(lonFile)
    Line Input #lonFile, strText
    ranPos.Offset(i).Value = strText
    i = i + 1
Loop
Close #lonFile
Set ranTmp = Range(ranPos, ranPos.End(xlDown))
'ranTmp.Replace What:="'", Replacement:=""
ranTmp.TextToColumns DataType:=xlDelimited, Comma:=True, _
FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2))
Cells.Select
Cells.EntireColumn.AutoFit
ranPos.Cells.Select
Set ranPos = Nothing
Set ranTmp = Nothing
End Sub
番外編　FSO
Sub Word_Ex()
'Microsoft Word11.0 Object Libray
Dim objWord As Word.Application
Dim tmpDoc As Word.document

Set objWord = New Word.Application
With objWord
    Set tmpDoc = .Documents.Add
    tmpDoc.Range.Text = "Excelから作成"
    tmpDoc.SaveAs "aaa.doc" 'C:\Users\ak\Documents\aaa.doc
    .Quit
End With

Set tmpDoc = Nothing
Set objWord = Nothing

End Sub

'Sub FSO_Ex()
'Microsoft Scripting Runime
'Dim objFSO As Scripting.FileSystemObject
'Dim tmpTS As Scripting.textstream
'
'Set objFSO = New Scripting.FileSystemObject
'Set tmpTS = objFSO.CreateTextFile("aaa.txt")   'C:\Users\ak\Desktop\aaa.txt
'With tmpTS
'    .WriteLine "FSO out text"
'    .WriteLine "日付" & Format(Now(), "m月d日h時mm分")
'    .Close
'End With
'
'Set tmpTS = Nothing
'Set objFSO = Nothing
'
'End Sub

Sub FSO_Ex1()
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO.CreateTextFile("C:\Users\ak\Desktop\aaa.txt")
    .WriteLine "FSO out text"
    .WriteLine "日付" & Format(Now(), "m月d日h時mm分")
    .Close
End With
Set objFSO = Nothing

End Sub

番外編
Sub sample()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim strFilename As String                                       'ファイル名(フルパス)
Dim strSheetName As String                                      'シート名
strFilename = "C:\Users\ak\Desktop\aaa.xls"                     'ファイル名をセット
strSheetName = "Sheet1"                                         'シート名をセット

Set xlApp = CreateObject("Excel.Application")                   'Application生成
Set xlApp = New Excel.Application

xlApp.Workbooks.Open Filename:=strFilename, UpdateLinks:=0      'EXCELを開く
xlApp.Visible = True                                            'EXCELの表示
Set xlBook = xlApp.Workbooks(Dir(strFilename))                  'Workbook
Set xlSheet = xlBook.Worksheets(strSheetName)                   'Worksheet
xlSheet.Cells(1, 1).Value = "HELLO"
xlBook.Close saveChanges:=True    'ブックを保存して終了
xlApp.Quit                        'EXCELを閉じる

Set xlSheet = Nothing             'オブジェクトの解放
Set xlBook = Nothing              'オブジェクトの解放
Set xlApp = Nothing               'オブジェクトの解放

End Sub