なぜVBAなのか？
- 開発環境構築が楽（Excelが入っていればOK）
- 導入できるソフトウェアに制限がある
ソースコード
mylib.bas
Option Explicit
'-------------------------------------------------------------------------------
' 指定時間プログラムを停止する。
'-------------------------------------------------------------------------------
' note : ミリ秒で指定。WindowsAPI。
'-------------------------------------------------------------------------------
Public Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
'-------------------------------------------------------------------------------
' 列名から列位置を取得する。
'-------------------------------------------------------------------------------
' param : aTargetSheet
' param : aColumnName 列名
' param : aRowIndexOfClomunName 列名が存在する行の位置
' return : 列名が存在する列の位置
'-------------------------------------------------------------------------------
Public Function GetColIndex(pTargetSheet As Worksheet, aColumnName As String, Optional pRowIndexOfClomunName As Long = 0) As String
GetColIndex = WorksheetFunction.Match(pColumnName, pTargetSheet.rows(pRowIndexOfClomunName), 0) '0:完全一致
End Function
'-------------------------------------------------------------------------------
' 文字列配列を検索し位置を返す。
'-------------------------------------------------------------------------------
' param : pArray 文字列配列
' param : searchString 検索文字列
' return : 文字列配列の位置。検索にヒットしない場合は-1を返す。
'-------------------------------------------------------------------------------
Public Function IndexOf(pArray As Variant, searchString As String) As Long
Dim i As Long
For i = 0 To UBound(pArray)
If pArray(i) = searchString Then
IndexOf = i
Exit Function
End If
Next
IndexOf = -1
End Function
'-------------------------------------------------------------------------------
' コマンド（～.exe）を実行する。
' またはファイルに関連付けられたアプリケーションを起動する
'-------------------------------------------------------------------------------
' param : pCommand コマンドまたはファイルパス
' param : pWindowStyle 0:ウィンドウ非表示
' 1:通常ウィンドウ
' param : pIsSync false:非同期
' true :同期
' return : 実行結果
' note : vbs対応のため、型定義なし
'-------------------------------------------------------------------------------
Public Function ExecCommand( _
pCommand, _
pWindowStyle, _
pIsSync As Boolean)
Dim wss
Set wss = CreateObject("WScript.Shell")
ExecCommand = wss.Run(pCommand, pWindowStyle, pIsSync)
End Function
'-------------------------------------------------------------------------------
' 多階層フォルダ作成（複数階層フォルダ作成）
'-------------------------------------------------------------------------------
' param : pFolderPath フォルダパス
' return :
' note : d:\tempというフォルダ構成に対して
' d:\temp\first\secondというフォルダを作成できる
' 一般的なフォルダ作成はfirstフォルダが存在していない場合エラー
' vbs対応のため、型定義なし
' dependence : ExecCommand
'-------------------------------------------------------------------------------
Public Sub MakeFolder(pFolderPath)
Call ExecCommand("cmd /c MD " & pFolderPath, 0, True)
End Sub
'-------------------------------------------------------------------------------
' フォルダパス文字列を結合する
'-------------------------------------------------------------------------------
' param : aFolderPath フォルダパス
' return :
' note : JF("d:\tmp", "backup") ⇒ d:\tmp\backup
'-------------------------------------------------------------------------------
Public Function JF(ParamArray pFolderPathArray() As Variant) As String
Dim path As String
Dim folderPath As Variant
For Each folderPath In pFolderPathArray
path = path & FormatFolderPath(CStr(folderPath))
Next
JF = path
End Function
'-------------------------------------------------------------------------------
' フォルダパス文字列の書式修正
'-------------------------------------------------------------------------------
' param : pFolderPath フォルダパス文字列
' return :
' note :
' FormatFolderPath("c:\dummy") → c:\dummy
' FormatFolderPath("c:\dummy\") → c:\dummy
' FormatFolderPath("subdir") → \subdir
' FormatFolderPath("\subdir\") → \subdir
' FormatFolderPath("\\nethoge\duumy")→ \\nethoge\dummy
' FormatFolderPath("\\nethoge\duumy\")→ \\nethoge\dummy
'-------------------------------------------------------------------------------
Private Function FormatFolderPath( _
pFolderPath As String)
Dim folderPath
folderPath = pFolderPath
'先頭に対する処理
If Mid(folderPath, 1, 2) = "\\" Or Mid(folderPath, 2, 1) = ":" Then
'処理なし
ElseIf Mid(folderPath, 1, 1) <> "\" Then
folderPath = "\" & folderPath
End If
'末尾に対する処理
If Right(folderPath, 1) = "\" Then
folderPath = Mid(folderPath, 1, Len(folderPath) - 1)
End If
FormatFolderPath = folderPath
End Function
'-------------------------------------------------------------------------------
' エクスプローラーを開く
'-------------------------------------------------------------------------------
' param : pFolderPath フォルダパス
'-------------------------------------------------------------------------------
Public Sub OpenExplorer( _
pFolderPath As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.folderexists(pFolderPath) Then
MsgBox "フォルダを指定してください" & vbCrLf & pFolderPath
Exit Sub
End If
CreateObject("Shell.Application").ShellExecute pFolderPath
End Sub
'-------------------------------------------------------------------------------
' エクスプローラーを開く（ファイルを選択状態にする）
'-------------------------------------------------------------------------------
' param : pFilePath
' dependence : Sleep、OpenExplorer
'-------------------------------------------------------------------------------
Public Sub OpenExplorerFileSelected( _
pFilePath As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim folderPath As String
folderPath = fso.GetParentFolderName(pFilePath)
OpenExplorer folderPath
Dim wb As Object
Do While wb Is Nothing
Sleep 500
Set wb = GetExplorer(folderPath)
Loop
Call wb.document.SelectItem(CVar(pFilePath), 21) '1+4+16
End Sub
Private Function GetExplorer( _
pFolder) As Object
Dim objExp
Set objExp = CreateObject("Shell.Application")
Dim wb As Object
For Each wb In objExp.Windows
If wb.Name = "エクスプローラー" _
And LCase(wb.document.folder.Self.path) = LCase(pFolder) Then
Set GetExplorer = wb
Exit Function
End If
Next
End Function
'-------------------------------------------------------------------------------
' ファイルまたはフォルダをコピーする。
'-------------------------------------------------------------------------------
' param : pSrcPath コピー元ファイルパス（コピー元フォルダパス）
' param : pDestPath コピー先ファイルパス（コピー先フォルダパス）
' note : フォルダの場合は末尾の「\」有無で動作が変わらないように対応
' vbs対応のため、型定義なし
' dependence: JF
'-------------------------------------------------------------------------------
Public Sub CopyItem(pSrcPath, pDestPath)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.folderexists(pSrcPath) Then
If fso.folderexists(pDestPath) Then
fso.CopyFolder JF(pSrcPath), JF(pDestPath) & "\", True 'True:上書き
Else
fso.CopyFolder JF(pSrcPath), JF(pDestPath), True 'True:上書き
End If
ElseIf fso.FileExists(pSrcPath) Then
If fso.folderexists(pDestPath) Then
fso.CopyFile pSrcPath, JF(pDestPath) & "\", True 'True:上書き
Else
fso.CopyFile pSrcPath, pDestPath, True 'True:上書き
End If
Else
Err.Raise 1, , "CopyItemが失敗しました（独自エラー）"
End If
End Sub
'-------------------------------------------------------------------------------
' ファイルまたはフォルダを削除する。
'-------------------------------------------------------------------------------
' param : pSrcPath 削除するファイルまたフォルダのパス
' note : フォルダの場合は末尾の「\」有無で動作が変わらないように対応
' vbs対応のため、型定義なし
' dependence: JF
'-------------------------------------------------------------------------------
Public Sub DeleteItem(pSrcPath)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.folderexists(pSrcPath) Then
fso.DeleteFolder JF(pSrcPath), False 'False:読み取り専用を削除しない
ElseIf fso.FileExists(pSrcPath) = True Then
fso.DeleteFile pSrcPath, False 'False:読み取り専用を削除しない
Else
Err.Raise 1, , "DeleteItemが失敗しました（独自エラー）"
End If
End Sub
'-------------------------------------------------------------------------------
' ファイルまたはフォルダを移動する。
'-------------------------------------------------------------------------------
Public Sub MoveItem(pSrcPath, pDestPath)
CopyItem pSrcPath, pDestPath
DeleteItem pSrcPath
End Sub
'-------------------------------------------------------------------------------
' 文字列をファイルに書き込む。
'-------------------------------------------------------------------------------
' param : pFilePath ファイルパス
' param : pText 書き込む文字列
' param : pAdditionalMode true :追加書き込み
' * false:通常書き込み
' param : pEncoding * 0 : utf-8 BOMなし
' 1 : shift_jis
' dependence: MakeFolder
' note : フォルダが存在していなければ作成する。
' : FSO版はUTF-8に対応していないため廃止。
'-------------------------------------------------------------------------------
Public Sub WriteFile( _
pFilePath As String, _
pText As String, _
Optional pAdditionalMode As Boolean = False, _
Optional pEncoding As Long = 0)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim folderPath As String
folderPath = fso.GetParentFolderName(pFilePath)
If Not fso.folderexists(folderPath) Then
Call MakeFolder(folderPath)
End If
With CreateObject("ADODB.Stream")
If pEncoding = 0 Then
.Charset = "utf-8"
ElseIf pEncoding = 1 Then
.Charset = "shift_jis"
End If
.Open
'追加書き込みの場合、書き込み位置を末尾に移動。
If pAdditionalMode And fso.FileExists(pFilePath) Then
.LoadFromFile pFilePath
.Position = .Size
End If
.WriteText pText, 0 '0:末尾改行なし
'utf-8の場合、BOM削除
If pEncoding = 0 Then
.Position = 0
.Type = 1 'バイナリ―モード
.Position = 3
Dim bin As Variant
bin = .Read()
.Position = 0
If Not IsNull(bin) Then
.Write = bin
End If
.SetEos
End If
.SaveToFile pFilePath, 2 '2:同名ファイルが存在してもエラーとしない
.Close
End With
End Sub
'-------------------------------------------------------------------------------
' テキストファイルの文字列を全て取得する。
'-------------------------------------------------------------------------------
' param : pFilePath ファイルパス
' : pEncodingType 文字コードタイプ * 0 : utf-8
' 1 : shift_jis
' : pLineSeparator 改行文字 * vbCrLf
' return : Variant(String配列)
' note : FSO版はUTF-8に対応していないため廃止
'-------------------------------------------------------------------------------
Public Function ReadFile( _
pFilePath As String, _
Optional pEncodingType As Long = 0, _
Optional pLineSeparator As String = vbCrLf _
) As Variant
With CreateObject("ADODB.Stream")
If pEncodingType = 0 Then
.Charset = "utf-8"
ElseIf pEncodingType = 1 Then
.Charset = "shift_jis"
End If
.Open
.LoadFromFile pFilePath
Dim arr As Variant
arr = Split(.ReadText, pLineSeparator)
ReadFile = arr
.Close
End With
End Function
'-------------------------------------------------------------------------------
' プロパティファイルを読み込む。
'-------------------------------------------------------------------------------
' param : pFilePath ファイルパス
' return : プロパティ（Dictionary型）
' note :
' Dim properties As Object
' Set properties = ReadProperties("ファイルパス")
' Debug.Print properties.item("キー")
'-------------------------------------------------------------------------------
Public Function ReadProperties(pFilePath As String) As Object
Dim properties As Object
Set properties = CreateObject("Scripting.Dictionary")
Dim rows() As String
rows() = ReadFile(pFilePath)
Dim row As Variant
For Each row In rows
If row = "" Then
GoTo continue1
End If
Dim key As String
Dim value As String
Dim var As Variant
var = Split(row, "=")
key = var(0)
value = var(1)
If key = "" Then
GoTo continue1
End If
properties.Add key, value
continue1:
Next
Set ReadProperties = properties
End Function
'-------------------------------------------------------------------------------
' 一時ファイルパス文字列を生成する
'-------------------------------------------------------------------------------
' param : pPathTail 拡張子を付けたい場合に指定する。例 ".bat"
' return : 生成した一時ファイルパス文字列
'-------------------------------------------------------------------------------
Public Function CreateTempFilePath( _
Optional pPathTail = "") As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
CreateTempFilePath = fso.GetSpecialFolder(2) & _
"\" & fso.GetBaseName(fso.GetTempName) & pPathTail
End Function
'-------------------------------------------------------------------------------
' テンプレート文字列に変数展開する
'-------------------------------------------------------------------------------
' param : pTemplateText テンプレート文字列
' param : pVal() 設定値
' return : 変数展開した文字列
' note : Here("私は${0}が${1}です", "ラーメン", "好き")
'-------------------------------------------------------------------------------
Public Function Here(pTemplateText, ParamArray pVal())
Const PRE As String = "${"
Const SUF As String = "}"
Dim text As String
text = pTemplateText
Dim i As Long
For i = 0 To UBound(pVal)
text = Replace(text, PRE & i & SUF, pVal(i))
Next
Here = text
End Function
'-------------------------------------------------------------------------------
' DBコネクションを取得する
'-------------------------------------------------------------------------------
' param :
' return :
' note :
' DB接続文字列の例
' 例1 Provider=OraOLEDB.Oracle;
' Data Source=(DESCRIPTION=(ADDRESS=(PROTOCOL=TCP)
' (HOST=localhost)(PORT=1521))(CONNECT_DATA=(SERVICE_NAME=XE)));
' User ID=scott;Password=tiger
' 例2 DSN=oracle xe;UID=scott;PWD=tiger
'-------------------------------------------------------------------------------
Public Function GetDBConnection(aDBConnectionString As String) As Object
Dim cn As Object
Set cn = CreateObject("ADODB.Connection")
cn.Open aDBConnectionString
Set GetDBConnection = cn
End Function
'-------------------------------------------------------------------------------
' 正規表現検索に使用するRegExpオブジェクトを作成する。
'-------------------------------------------------------------------------------
' param : pPattern 正規表現パターン
' param retrun: rObjRegExp RegExpオブジェクト
' note :
' '[How to use]
' Dim regExpAbc As Object
' CreateRegExp "c(c.+d)e", regExpAbc
' Dim ms As Object
' Dim m As Object
' Set ms = regExpAbc.Execute("aabbccddee")
' For Each m In ms
' Debug.Print m.value '⇒ ccdde
' Debug.Print m.submatches(0) '⇒ cdd
' Next
'
' 'replace
' Dim str As String
' str = regExpAbc.Replace("aabbccddee", "xxx") '⇒ aabbxxxe
'
'-------------------------------------------------------------------------------
Public Sub CreateRegExp(pPattern As String, ByRef prObjRegExp As Object)
Set prObjRegExp = CreateObject("VBScript.RegExp")
prObjRegExp.pattern = pPattern
prObjRegExp.IgnoreCase = False 'False:大文字と小文字を区別する
prObjRegExp.Global = True 'True:文字列全体を検索、False:1回目のマッチで終了
prObjRegExp.multiLine = True 'True:通常、False:^や$が文字列全体の先頭と末尾になる
End Sub
'オブジェクトのcountが1件以上の場合trueを返す
Public Function HasItems(obj As Object)
If Not obj Is Nothing And obj.Count >= 1 Then
HasItems = True
Exit Function
End If
HasItems = False
End Function
'-------------------------------------------------------------------------------
' batファイルを実行する。
'-------------------------------------------------------------------------------
' param : pBatFilePath batファイルパス
' return : batファイルの戻り値
' note :
'-------------------------------------------------------------------------------
Public Function ExecBat(pBatFilePath As String) As Long
ExecBat = ExecCommand(pBatFilePath, 1, True)
End Function
'-------------------------------------------------------------------------------
' シートが1個の新規ブックを作成する。
'-------------------------------------------------------------------------------
' param :
' return : 新規ブック
' note :
'-------------------------------------------------------------------------------
Public Function CreateOneSheetBook() As Workbook
Dim bakSheetCount As Integer
bakSheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Dim resultBook As Workbook
Set resultBook = Workbooks.Add
resultBook.Sheets(1).Cells.Font.Name = "ＭＳ ゴシック"
Application.SheetsInNewWorkbook = bakSheetCount
Set CreateOneSheetBook = resultBook
End Function
'-------------------------------------------------------------------------------
' ワークシートの最終行の行位置を取得する
'-------------------------------------------------------------------------------
' param : pSheet ワークシート
' param : pCol 最終行を検証する列位置
' return : 最終行の行位置
' note : UsedRangeはセルに値が無くても罫線や色が設定されていると行位置
' として検出されてしまう。
' findメソッド版は検索と置換ダイアログに影響がある為､廃止｡
'-------------------------------------------------------------------------------
Public Function GetLastRow( _
pSheet As Worksheet, _
Optional pCol As Long = 0) As Long
Dim row As Long
If pCol = 0 Then
row = pSheet.UsedRange.rows(pSheet.UsedRange.rows.Count).row
Else
row = pSheet.Cells(pSheet.rows.Count, pCol).End(xlUp).row
End If
GetLastRow = row
End Function
'-------------------------------------------------------------------------------
' ワークシートの最終列の列位置を取得する
'-------------------------------------------------------------------------------
' param : pSheet ワークシート
' param : pRow 最終列を検証する行位置
' return : 最終列の列位置
' note : sedRangeはセルに値が無くても罫線や色が設定されていると行位置
' として検出されてしまう｡
' findメソッド版は検索と置換ダイアログに影響がある為､廃止｡
'-------------------------------------------------------------------------------
Public Function GetLastColumn( _
pSheet As Worksheet, _
Optional pRow As Long = 0) As Long
Dim col As Long
If pRow = 0 Then
col = pSheet.UsedRange.Columns(pSheet.UsedRange.Columns.Count).Column
Else
col = pSheet.Cells(pRow, pSheet.Columns.Count).End(xlToLeft).Column
End If
GetLastColumn = col
End Function
'-------------------------------------------------------------------------------
' CSVファイルをExcelで開く QueryTables版
'-------------------------------------------------------------------------------
' param : pCsvFilePath CSVファイルパス
' param : pSeparator 区切り文字
' param : aEncoding * 65001:UTF-8
' 932:Shift-JIS
' param : pHeadingWindowLockFlag ヘッダ部ウィンドウ固定
'-------------------------------------------------------------------------------
Public Sub OpenCsv( _
pCsvFilePath As String, _
Optional pSeparator As String = ",", _
Optional pEncoding As Long = 65001, _
Optional pHeadingWindowLockFlag As String = False)
Dim columnDataTypes(255) As Long
Dim i As Long
For i = 0 To 255
columnDataTypes(i) = 2 '2:xlTextFormat
Next
Dim newSheet As Worksheet
Set newSheet = CreateOneSheetBook.Sheets(1)
newSheet.Cells.Font.Name = "ＭＳ ゴシック"
Dim qt As QueryTable
Set qt = newSheet.QueryTables.Add(Connection:="text;" & pCsvFilePath, _
Destination:=newSheet.Range("A1"))
qt.TextFileOtherDelimiter = pSeparator
qt.TextFileColumnDataTypes = columnDataTypes
qt.TextFilePlatform = pEncoding
qt.Refresh
qt.Delete
newSheet.Cells.Columns.AutoFit
If pHeadingWindowLockFlag Then
newSheet.Range("A2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
End If
End Sub
'-------------------------------------------------------------------------------
' ブックが開いているかチェック
'-------------------------------------------------------------------------------
Public Function IsOpenedBook( _
pBookName As String) As Boolean
IsOpenedBook = False
Dim book As Workbook
For Each book In Workbooks
If book.Name = pBookName Then
IsOpenedBook = True
Exit Function
End If
Next
End Function
'-------------------------------------------------------------------------------
' シート存在チェック
'-------------------------------------------------------------------------------
Public Function ExistsSheet( _
pBook As Workbook, _
pSheetName As String) As Boolean
Dim sheet As Worksheet
For Each sheet In pBook.Worksheets
If sheet.Name = pSheetName Then
ExistsSheet = True
Exit Function
End If
Next
ExistsSheet = False
End Function
'-------------------------------------------------------------------------------
' 配列の最後に値を追加
'-------------------------------------------------------------------------------
' param : pArray 配列
' return : pValue 値
' note : pArrayに要素数未指定の配列変数を指定するとエラーになる。
' その場合はArray()で初期化して渡す。
' Dim arr As Variant
' arr = Array()
' Call AddArray(arr,"hoge")
'-------------------------------------------------------------------------------
Public Function AddArray( _
ByRef pArray As Variant, _
pValue As Variant)
ReDim Preserve pArray(UBound(pArray) + 1)
pArray(UBound(pArray)) = pValue
End Function
'-------------------------------------------------------------------------------
' ブック、シートの体裁を整える
'-------------------------------------------------------------------------------
Public Sub FormatBook()
'各シートの体裁を整える
Dim sheet As Worksheet
For Each sheet In ActiveWorkbook.Sheets
If sheet.Visible = True Then
sheet.Activate
'表示倍率 85%
ActiveWindow.Zoom = 85
'A1セルを選択
Application.Goto sheet.Range("A1"), True
End If
Next
'先頭シートを選択
Dim i As Long
For i = 1 To ActiveWorkbook.Sheets.Count
If ActiveWorkbook.Sheets(i).Visible = True Then
ActiveWorkbook.Sheets(i).Select
Exit Sub
End If
Next
End Sub