|
|
|||||||||
| 本章では、ファイル操作に関するコードサンプルを例示します。 | |||||||||
|
|||||||||
|
Dim mypath As String
mypath = ActiveWorkbook.Path & "\" |
|||||||||
|
|||||||||
|
|
Sub Conf() Dim flName As String With Application.FileSearch .NewSearch .LookIn = "myPath" .SearchSubFolders = True .FileName = flName .MatchTextExactly = True .FileType = msoFileTypeAllFiles If .Execute() = 0 Then Exit Sub End With End Sub |
||||||||
| ユーザーからファイル名を取得するために[ファイルを開く] ダイアログ ボックスを表示する | |||||||||
|
|||||||||
| Option Explicit Dim myPath As String 'ファイルのパス名 Dim flName As String 'ファイルのファイル名 Sub Disp() Dim getfile As Variant '固定長ファイル名 Dim st1, posMj As Integer myPath = "" flName = "" 'ダイアログボックスにてファイル名取得 getfile = Application.GetOpenFilename("ﾃｷｽﾄ ﾌｧｲﾙ (*.txt), *.txt", , "ファイル名の指定") If getfile = False Then Exit Sub 'パス名とファイル名に分離 st1 = 1 Do Until st1 = 0 posMj = st1 '\の位置 st1 = st1 + 1 st1 = InStr(st1, getfile, "\", 1) Loop myPath = Mid(getfile, 1, posMj) flName = Mid(getfile, posMj + 1, Len(getfile) - posMj) End Sub |
|||||||||
|
|
|||||||||
|
|||||||||
|
Workbooks.Open FileName:="c:\.......xls"
|
|||||||||
|
|||||||||
|
Workbooks(oflname).Close saveChanges:=False
セーブ Workbooks(nflname).SaveAs FileName:=omypath Workbooks(oflname).Close saveChanges:=True |
|||||||||
|
|||||||||
|
ActiveWorkbook.Save
|
|||||||||
|
|||||||||
|
ファイルを削除します.
Kill "TestFile" カレント ディレクトリにあるすべての *.txt ファイルを削除します. Kill "*.txt" ファイルを削除します. mypath = ActiveWorkbook.Path & "\" Kill mypath & "宛名.DOC" |
|||||||||
|
|||||||||
|
ChDir "C:\WINDOWS\ﾃﾞｽｸﾄｯﾌﾟ"
|
|||||||||
|
|||||||||
| Sub CSVファイルを開くダイアログボックスを表示する() Dim getfile As Variant getfile = Application.GetOpenFilename("CSV ﾌｧｲﾙ (*.csv), *.csv", , "Justファイルの参照") If getfile = False Then Exit Sub End Sub |
|||||||||
|
|||||||||
| Sub 固定長ファイルをExcelシートに取り込む() Dim getfile As Variant 'ダイアログボックスから取得したファイル名（パス含む） Dim myPath As String 'ファイルのパス名 Dim flName As String 'ファイルのファイル名 Dim lastGyo As Integer '項目定義シート"桁数"列の最終行 Dim rlen As Integer 'レコード長 Dim rMax As Long 'レコード件数 Dim mdsYm As Integer '見出し有＝１、無＝０ Const Sheet1 = "使用方法" Const Sheet2 = "項目定義" Const Sheet3 = "データシート" Dim NewBook As Workbook Dim buf As String 'レコードバッファー Dim strl As String Dim i As Long Dim j As Long Dim bufPos As Long Dim celValue As String '項目の値 Dim colLen As Integer '項目の桁数 Dim colUdr As Integer '小数桁数 Reset 'ファイルがあるか確認する myPath = Sheets(Sheet2).Cells(3, 2) flName = Sheets(Sheet2).Cells(5, 2) With Application.FileSearch .NewSearch .LookIn = myPath .SearchSubFolders = True .Filename = flName .MatchTextExactly = True '.FileType = msoFileTypeAllFiles If .Execute() = 0 Then MsgBox "ファイルが見つかりません" Exit Sub End If End With 'データシートをクリアする With Sheets(Sheet3) .Range(.Cells(1, 1), .Cells.SpecialCells(xlLastCell)).Clear End With '項目定義シートの桁数列の最終行を求める lastGyo = Sheets(Sheet2).Range("E65536").End(xlUp).Row 'レコード長を求める Call レコード長を求める 'Open myPath & "\" & flName For Random Access Read As #1 Len = rlen Open myPath & "\" & flName For Input Access Read As #1 Len = rlen 'レコード件数を求める rMax = Fix(LOF(1) / rlen) '見出しを作成する i = 1 If mdsYm = 1 Then For i = 8 To lastGyo Sheets(Sheet3).Cells(1, i - 7) = Sheets(Sheet2).Cells(i, 3).Value Next i End If '列幅を設定する i = 1 If mdsYm = 1 Then For i = 8 To lastGyo j = i - 7 Sheets(Sheet3).Columns(j).ColumnWidth = Len(Sheets(Sheet2).Cells(i, 3)) * 2 Next i End If 'データを設定する For i = 1 To rMax 'Get #1, i, buf buf = Input(rlen, 1) bufPos = 1 For j = 1 To 999 colLen = Sheets(Sheet2).Cells(j + 7, 5).Value '桁数 colUdr = Sheets(Sheet2).Cells(j + 7, 6).Value '小数桁 If colLen < 1 Then Exit For celValue = "'" + Mid(buf, bufPos, colLen) '項目の値 '値のセット If colUdr > 0 Then '小数桁 Sheets(Sheet3).Cells(i + mdsYm, j).Value = Mid(celValue, 1, colLen - colUdr + 1) _ & "." & _ Mid(celValue, colLen - colUdr + 2) Else Sheets(Sheet3).Cells(i + mdsYm, j).Value = celValue End If bufPos = bufPos + colLen If bufPos > rlen Then Exit For Next Next '状態を保存する ActiveWorkbook.Save '別のブックに保存するか確認する myPath = Sheets(Sheet2).Cells(3, 8) flName = Sheets(Sheet2).Cells(5, 8) If myPath & flName <> ActiveWorkbook.Path & ActiveWorkbook.Name Then '別のブックに保存 With Application.FileSearch .NewSearch .LookIn = myPath .SearchSubFolders = True .Filename = flName .MatchTextExactly = True '.FileType = msoFileTypeAllFiles If .Execute() = 0 Then '新しく作成 Sheets(Sheet3).Activate Cells.Select Application.CutCopyMode = False Selection.Copy Set NewBook = Workbooks.Add(xlWBATWorksheet) NewBook.Sheets(1).Name = Sheet3 NewBook.Sheets(Sheet3).Activate Cells.Select '貼り付け（すべて） Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False NewBook.SaveAs Filename:=myPath & "\" & flName Workbooks(flName).Close saveChanges:=False Else '既存ブックに保存 Sheets(Sheet3).Activate Cells.Select Application.CutCopyMode = False Selection.Copy Workbooks.Open Filename:=myPath & "\" & flName 'シートがあるか？？？？？？？？？？？？？？？？？？？？？？ Workbooks(flName).Worksheets(Sheet3).Activate Cells.Select '貼り付け（すべて） Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Workbooks(flName).Close saveChanges:=True End If End With End If Sheets(Sheet1).Activate Cells(1.1).Select MsgBox Str(rMax) + "件作成しました。" End Sub Sub レコード長を求める() Dim myRange As Range '項目定義シートの範囲 Sheets(Sheet2).Activate Set myRange = Sheets(Sheet2).Range(Cells(8, 5), Cells(lastGyo, 5)) rlen = Application.Sum(myRange) End Sub |
|||||||||
|
|||||||||
| Data.txt というテキスト ファイルを、タブを区切り文字として分析し、ワークシートに変換する。 Workbooks.OpenText filename:="DATA.TXT", _ dataType:=xlDelimited, tab:=True |
|||||||||
|
|||||||||
| Set newModule = Modules.Add newModule.InsertFile fileName:="testcode.txt" |
|||||||||
|
|||||||||
| Sub CSV_Download() ' 'ワークシートの内容をCSV形式のテキストファイルに出力する（""付） ' '以下のパラメータを設定してください Const File_nm As String = "Denpyo.txt" '← テキストファイル名（拡張子付） Const Sheet_nm As String = "Sheet1" '← 出力する当該ブックのシート名 Const Row_num As Long = 8 '← 出力するシートの列数 Dim MyPath As String ' このBOOKのパス名 Dim csvFILENAME As String ' 作成するcsvファイル名(フルパス) Dim X() As String ' 書き出すレコードの内容 Dim GYOMAX As Long ' データが収容された最終行 Dim GYO As Long ' 収容するセルの行(Work) Dim COL As Long ' 列の位置(Work) Dim lngREC As Long ' レコード件数カウンタ ReDim X(Row_num) ' テキストファイル名をセットする MyPath = ActiveWorkbook.Path csvFILENAME = MyPath & "\" & File_nm 'シートの最終行を求める Worksheets(Sheet_nm).Activate ' シートをactiveにする ActiveSheet.UsedRange.Select ' シートの有効行を選択する GYOMAX = Selection.Rows.Count '「GYOMAX」に最終行をセットする ' 作成するcsvファイルをOPEN(出力モード)する Open csvFILENAME For Output As #1 ' シートの1行目（1〜n列）から最終行までをテキストファイルに出力する For GYO = 1 To GYOMAX For COL = 1 To 8 X(COL) = "" & ActiveSheet.Cells(GYO, COL).Value & "" Next COL For i = 1 To Row_num - 1 ' レコードを出力 Write #1, X(i); '改行を阻止するため後ろに 「;」を付ける Next Write #1, X(Row_num) lngREC = lngREC + 1 ' レコード件数カウンタの加算 Next ' 作成したcsvファイルをCLOSEする Close #1 ' 終了の表示 MsgBox "ファイル出力が完了しました。" & vbCr & "レコード件数=" & lngREC & "件" End Sub |
|||||||||
|
|||||||||
| Sub CSV_Download() Dim MyPath As String ' このBOOKのパス名 Dim csvFILENAME As String ' 作成するcsvファイル名(フルパス) Dim X(1 To 8) As Variant ' 読み込むレコード内容 Dim GYO As Long ' 収容するセルの行(Work) Dim COL As Long ' 列の位置(Work) Dim lngREC As Long ' レコード件数カウンタ ' テキストファイル名をセットする Mypath = ActiveWorkbook.Path csvFILENAME = Mypath & "\" & "Denpyo.txt" ' csvファイルをOPEN(入力モード)する Open csvFILENAME For Input As #1 Worksheets("sheet1").Activate ' シートをactiveにする lngREC = 0 Do Until EOF(1) lngREC = lngREC + 1 Input #1, X(1), X(2), X(3), X(4), X(5), X(6), X(7), X(8) ' レコードを入力する GYO = lngREC + 2 ' シートの3行目以降に書き込む For COL = 1 To 8 ActiveSheet.Cells(GYO, COL).Value = X(COL) Next COL Loop ' 作成したcsvファイルをCLOSEする Close #1 ' 終了の表示 MsgBox "ファイル入力が完了しました。" & vbCr & "レコード件数=" & lngREC & "件" End Sub ※ EOF関数は、ランダムアクセスモードまたはシーケンシャル入力モードで開いたファイルの現在位置がファイルの末尾に達しているときTrueを返します。（最終のレコードを読んだときにTrueを返す） EOF(filenumber) 引数fienumberには、現在開いているファイルを表す有効なファイル番号を指定します。 |
|||||||||
|
|||||||||
| メモ帳を起動する Sub memo() Dim RV RV = Shell("NOTEPAD.EXE", 1) AppActivate RV 'アクティブにする End Sub 電卓を起動する Sub memo() Dim RV RV = Shell("CALC.EXE", 1) AppActivate RV 'アクティブにする End Sub テキストファイルを開く Sub memo() Call Shell("NOTEPAD C:\Temp\sample.txt", 1) End Sub ワードファイルを開く Sub memo() Call Shell("WINWORD.EXE C:\Temp\sample.doc", 1) End Sub パワーポイントファイルを開く Sub memo() Call Shell("POWERPNT.EXE C:\Temp\sample.ppt", 1) End Sub URLを指定してＩＥを起動する Sub url() Dim objIE As Object 'ＩＥ参照用オブジェクト Set objIE = CreateObject("InternetExplorer.application") 'IEのオブジェクトを作る objIE.Visible = True '見えるようにする objIE.Navigate "http://・・・・" '.URLを開く End Sub |
|||||||||
|
|||||||||
| 'Excelブックをメールに添付して送信する ActiveWorkbook.SendMail Recipients:="xxxx@xxxxxxxx", Subject:="test" |
|||||||||
|
|||||||||
| Const cnsTARG As String = "C:\Documents and Settings\nobuyuki\デスクトップ\a.txt"
' 元ファイル Const cnsDEST As String = "C:\Documents and Settings\nobuyuki\デスクトップ\b.txt" ' 先ファイル FileCopy cnsTARG, cnsDEST 'ファイルをコピーする Kill cnsTARG ' 元ファイルを削除する |
|||||||||
|
|||||||||
| Webサイトの情報を入手する Dim HTTP As Object Set HTTP = CreateObject("MSXML2.XMLHTTP") 'MSXML2.XMLHTTPオブジェクトを生成する targetURI, = "http:// ・・・ " 'アクセスするURLをセット HTTP.Open "GET", targetURI, False HTTP.Send Buf = StrConv(HTTP.ResponseBody, vbUnicode) Set Http = Nothing 文字コードが Shift-JIS であれば'StrConv 関数で Unicode に変換できるが、EUC や JIS の場合は'NKF32.DLL などでいったん Shift-JIS に変換してやる必要があります。 |
|||||||||
| ご意見・ご感想をお寄せください。info@beagle-hc.com ‖ このサイトについて | |||||||||
| Copyright 2006 - 2009 uTRAM Corp. All Rights Reserved | |||||||||
くすりのこと
