| |
'こんなので善いのかな？
'基本的には、BinaryモードでInputB関数で読み込みます
'データが書き込まれるWorkSheetは、Upしたコードではアクティブシートです
'検証不足なので上手くいかなかったらゴメン
Option Explicit
Public Sub ReadFixdText()
Dim wksWrite As Worksheet
Dim lngRecLen As Long
Dim lngLineMax As Long
Dim vntFileName As Variant
Dim lngWriteRow As Long
Dim lngWriteCol As Long
'ディフォルトのファイル名を指定
vntFileName = "TestFile.txt"
If Not GetReadFile(vntFileName, ThisWorkbook.Path, False) Then
Exit Sub
End If
'Openするファイル名を設定
' vntFileName = ThisWorkbook.Path & "\" & "TestFile.txt"
If Dir(vntFileName) = "" Then
Beep
MsgBox vntFileName & vbCrLf & "ファイルが有りません"
Exit Sub
End If
'画面更新を停止
Application.ScreenUpdating = False
'書き込み行の初期値を設定
lngWriteRow = 1
'書き込み列の初期値を設定
lngWriteCol = 1
'書き込むシート名の参照を設定
Set wksWrite = ActiveSheet
'フィールド長の設定
lngRecLen = 72
'総行数確認
lngLineMax = FileLen(vntFileName) \ lngRecLen
If lngLineMax + lngWriteRow > 65536 Then
Beep
MsgBox "Dataが" & lngLineMax & _
"行有り、65536行を超えています", _
vbExclamation + vbOKOnly, "OverFlow"
Exit Sub
End If
'ファイルの読み込み
SDFRead vntFileName, lngRecLen, _
wksWrite, lngWriteRow, lngWriteCol
Set wksWrite = Nothing
'画面更新を再開
Application.ScreenUpdating = True
Beep
MsgBox "処理が終了しました", vbOKOnly, "終了"
End Sub
Private Sub SDFRead(ByVal strFileName As String, _
lngRecLen As Long, _
ByVal wksWrite As Worksheet, _
Optional lngRow As Long = 2, _
Optional lngCol As Long = 1)
'lngRow = 2 : シートのデータ書き込み先頭行位置
'lngCol = 1 : シートのデータ書き込み先頭列位置
Dim dfn As Integer
Dim vntField As Variant
'読み込むファイルをBinaryファイルとしてOpen
dfn = FreeFile
Open strFileName For Binary Access Read As dfn
'最終バイト数まで繰り返す
Do Until LOF(dfn) <= Loc(dfn)
'フィールドData作成
vntField = StrConv(InputB(lngRecLen, #dfn), vbUnicode)
'List書きこみ
wksWrite.Cells(lngRow, lngCol).Value = vntField
'書き込み行の更新
lngRow = lngRow + 1
Loop
Close #dfn
End Sub
Public Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean = False) As Boolean
Dim strFilter As String
'フィルタ文字列を作成
strFilter = "CSV File (*.csv),*.csv," & _
"Text File (*.txt),*.txt," & _
"CSV and Text (*.csv; *.txt),*.csv;*.txt," & _
"全て (*.*),*.*"
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames, False
End If
vntFileNames _
= Application.GetOpenFilename(strFilter, 2, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
Hirofumi
- 04/9/9(木) 20:04 -
