smCommon 

Option Explicit
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'このモジュールはエクセルの機能(表示や範囲など)に関連した関数をまとめたものです。
'Update 2019.07.15 nezu

'このモジュールはライブラリを使用しています。
'ツール(T)=>参照設定(R)で以下を追加してください。
'・Microsoft Scripting Runtime
'・Microsoft VBScript Regular Expressions 5.5
'・Microsoft Visual Basic for ApplicationsExtensibility *.*

'メモリ構造体
Private Type MEMORYSTATUS
    dwLength As Long        'MEMORYSTATUSの大きさ
    dwMemoryLoad As Long    '使用中メモリの割合
    dwTotalPhys As Long     '全物理メモリ
    dwAvailPhys As Long     '空き物理メモリ
    dwTotalPageFile As Long 'ページング可能な最大ファイルサイズ
    dwAvailPageFile As Long '現在ページング可能なファイルサイズ
    dwTotalVirtual As Long  '最大仮想メモ
    dwAvailVirtual As Long  '現在使用可能な仮想メモリ
End Type
    
'動作モード
Public Type sOperationMode
    Calculation As Integer
    DisplayAlerts As Boolean
    ScreenUpdating As Boolean
End Type

'カラーインデックス
Public Enum eColorIndex
    BLACK = 1
    RED = 3
    Gray = 15
    MAGENTA = 7
    PINK = 38
    Orange = 45
    Yellow = 27
    LightYellow = 19
    Bule = 32
    LightBule = 37
    LightGreen = 35
    LightCyan = 34
    White = 2
    LightPurple = 24
    none = 0
End Enum

Public Const ERROR_PARAM_LONG = -2147483648#
Public Const ERROR_PARAM_DOUBLE = -4.94065645841247E-324


'▼▼▼ ステータス表示/高速化関連 ▼▼▼
'機能:ステータスバーに時刻と任意の文字列を表示する
'引数:表示したいメッセージ
Public Function UpdateMassge(ByVal Message As String, Optional ByVal isDebugPrint As Boolean = False)
    Application.StatusBar = format(Now, "yyyy/MM/dd hh:mm:ss") + " " + Message
    If isDebugPrint Then Debug.Print format(Now, "yyyy/MM/dd hh:mm:ss") + " " + Message
    DoEvents '画面更新
End Function

'機能:画面更新、警告、数式の計算を無効にする
Public Function SilentMode()
    Dim isSaved As Boolean: isSaved = ActiveWorkbook.Saved
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.ShowWindowsInTaskbar = False
    Application.Calculation = xlCalculationManual
    If isSaved Then ActiveWorkbook.Saved = True
End Function

'機能:画面更新、警告、数式の計算を有効にする
Public Function SilentModeRelease()
    Dim isSaved As Boolean: isSaved = ActiveWorkbook.Saved
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.ShowWindowsInTaskbar = True
    If isSaved Then ActiveWorkbook.Saved = True
End Function

'機能:画面更新、警告、数式の状態を記録する
Public Function RecordOperationMode() As sOperationMode
    RecordOperationMode.ScreenUpdating = Application.ScreenUpdating
    RecordOperationMode.DisplayAlerts = Application.DisplayAlerts
    RecordOperationMode.Calculation = Application.Calculation
End Function

'機能:画面更新、警告、数式の状態を変更する
Public Function SetOperationMode(ByRef som As sOperationMode)
    Dim isSaved As Boolean: isSaved = ActiveWorkbook.Saved
    Application.Calculation = som.Calculation
    Application.DisplayAlerts = som.DisplayAlerts
    Application.ScreenUpdating = som.ScreenUpdating
    If isSaved Then ActiveWorkbook.Saved = True
End Function
'▲▲▲ ステータス表示/高速化関連 ▲▲▲



'▼▼▼ レンジ関連 ▼▼▼
'機能:値が入った一番大きい行の行番号を取得する
'引数1:ワークシート
'引数2:列番号(省略時:1)
'戻り値:最終行番号
Public Function SearchRowTail(ByVal ws As Worksheet, ByVal ref As Long) As Long
    Dim tail As Long
    tail = ws.Cells(ws.rows.Count, ref).End(xlUp).row
    
    '結合対策
    If ws.Cells(tail, ref).MergeCells Then tail = tail + ws.Cells(tail, ref).MergeArea.rows.Count - 1
    
    SearchRowTail = tail
End Function

'機能:値が入った一番大きい列の列番号を取得する
'引数1:ワークシート
'引数2:行番号(省略時:1)
'戻り値:最終列番号
Public Function SearchColTail(ByVal ws As Worksheet, ByVal ref As Long) As Long
    Dim tail As Long
    tail = ws.Cells(ref, ws.columns.Count).End(xlToLeft).column
    
    '結合対策
    If ws.Cells(ref, tail).MergeCells Then tail = tail + ws.Cells(ref, tail).MergeArea.columns.Count - 1
    
    SearchColTail = tail
End Function

'機能:Rangeを取得する
'引数1:対象ワークシート
'引数2:開始行
'引数3:開始列
'引数4:最終行
'引数5:最終列
'戻り値:範囲
Public Function GetRange(ByRef ws As Worksheet, ByVal r1 As Long, ByVal c1 As Long, ByVal r2 As Long, ByVal c2 As Long) As Range
    Set GetRange = ws.Range(ws.Cells(r1, c1), ws.Cells(r2, c2))
End Function

'機能:結合したセルの値を取得する
'引数1:範囲
'戻り値:値
'コメント:複数セルを結合している場合、1セル目以外のアドレスを指定すると空が返ってきてしまう問題の対策用
Public Function FirstValue(ByRef rng As Range) As Variant
    If rng.MergeCells Then
        FirstValue = rng.MergeArea.Cells(1, 1).value
    Else
        FirstValue = rng.value
    End If
End Function

'機能:範囲からキーワードに一致するセルを検索する
'引数1:範囲
'引数2:キーワード
'引数3:前回一致セル(連続検索用:省略可)
'引数4:初回一致アドレス(連続検索用:省略可)
'引数5:完全一致 or 部分一致(省略時:完全一致)
'引数6:検索順(省略時:列)
'戻り値:一致したセル
'コメント:複数一致するセルがある場合は、2回目以降の検索は第2,3引数を指定する
Public Function SearchCell(ByRef rng As Range, ByVal key As Variant, _
       Optional ByVal before As Range = Nothing, Optional ByVal stop_addrres As String = "", _
       Optional ByVal LookAt As Excel.XlLookAt = xlWhole, _
       Optional ByVal sorder As Excel.XlSearchOrder = xlByColumns, _
       Optional ByVal isMatchCase As Boolean = True, _
       Optional ByVal ismatchByte As Boolean = True) As Range
    If rng Is Nothing Then Exit Function
    If before Is Nothing Then Set before = rng.Cells(rng.rows.Count, rng.columns.Count)
    
    Dim res As Range
    Set res = rng.find(key, after:=before, LookIn:=xlValues, LookAt:=LookAt, _
                       searchorder:=sorder, SearchDirection:=xlNext, MatchCase:=isMatchCase, _
                       matchbyte:=ismatchByte, SearchFormat:=False)
    
    If res Is Nothing Then Exit Function
    If Len(stop_addrres) > 0 And res.address = stop_addrres Then Set res = Nothing
    
    Set SearchCell = res
End Function

'指定した範囲をソートする
'引数1:範囲
'引数2:ヘッダの有無
'引数3:基準1
'引数4:基準1の昇降順
'引数5:基準2
'引数6:基準2の昇降順
'引数7:基準3
'引数8:基準3の昇降順
Public Function RangeSort(ByRef rng As Range, ByVal existsHeader As Boolean, _
                          ByVal key1 As Long, Optional ByVal order1 As XlSortOrder = xlAscending, _
                 Optional ByVal key2 As Long, Optional ByVal order2 As XlSortOrder = xlAscending, _
                 Optional ByVal key3 As Long, Optional ByVal order3 As XlSortOrder = xlAscending)
    If rng Is Nothing Then Exit Function
    If key2 = 0 Then
        Call rng.Sort(key1:=rng.Parent.Cells(rng.row - IIf(existsHeader, -1, 0), key1), order1:=order1, header:=IIf(existsHeader, xlYes, xlNo))
    ElseIf key3 = 0 Then
        Call rng.Sort(key1:=rng.Parent.Cells(rng.row - IIf(existsHeader, -1, 0), key1), order1:=order1, _
                      key2:=rng.Parent.Cells(rng.row - IIf(existsHeader, -1, 0), key2), order2:=order2, header:=IIf(existsHeader, xlYes, xlNo))
    Else
        Call rng.Sort(key1:=rng.Parent.Cells(rng.row - IIf(existsHeader, -1, 0), key1), order1:=order1, _
                      key2:=rng.Parent.Cells(rng.row - IIf(existsHeader, -1, 0), key2), order2:=order2, _
                      key3:=rng.Parent.Cells(rng.row - IIf(existsHeader, -1, 0), key3), order3:=order3, header:=IIf(existsHeader, xlYes, xlNo))
    End If

End Function

'指定した範囲の条件に一致するユニークなセルがいくつあるかカウントする
'引数1:カウント対象範囲
'引数2:条件対象範囲1
'引数3:条件1
'引数4:条件対象範囲2
'引数5:条件2
'引数6:条件対象範囲3
'引数7:条件3
Public Function CountUniq(ByRef 検索条件範囲 As Range, _
                           Optional ByRef 検索条件範囲1 As Range, Optional ByVal 検索条件1 As String, _
                           Optional ByRef 検索条件範囲2 As Range, Optional ByVal 検索条件2 As String, _
                           Optional ByRef 検索条件範囲3 As Range, Optional ByVal 検索条件3 As String) As Long
                           
    If 検索条件範囲 Is Nothing Then Exit Function
    
    Dim arr As Variant: arr = 検索条件範囲
    Dim arrChk1 As Variant, arrChk2 As Variant, arrChk3 As Variant
    If 検索条件範囲1 Is Nothing = False Then arrChk1 = 検索条件範囲1
    If 検索条件範囲2 Is Nothing = False Then arrChk2 = 検索条件範囲2
    If 検索条件範囲3 Is Nothing = False Then arrChk3 = 検索条件範囲3
    
    Dim dic As New Scripting.Dictionary
    Dim row As Long, col As Long
    For row = 1 To 検索条件範囲.rows.Count
        If 検索条件範囲1 Is Nothing = False Then If arrChk1(row, 1) <> 検索条件1 Then GoTo NextLoop
        If 検索条件範囲2 Is Nothing = False Then If arrChk2(row, 1) <> 検索条件2 Then GoTo NextLoop
        If 検索条件範囲3 Is Nothing = False Then If arrChk3(row, 1) <> 検索条件3 Then GoTo NextLoop
        If dic.Exists(arr(row, 1)) = False Then Call dic.add(arr(row, 1), Empty)
NextLoop:
    Next row
    
    CountUniq = dic.Count
End Function

'同じ文字列の入ったセルを結合する
'引数1:指定範囲
Public Function MargeRange(ByRef rng As Range)
    Dim dr As Boolean
    dr = Application.DisplayAlerts
    Application.DisplayAlerts = False
    
    Dim serial As Long
    
    Dim row As Long, col As Long
    For row = 1 To rng.rows.Count
        For col = 1 To rng.columns.Count
            If rng.Cells(row, col).value = Empty Then
                serial = 0
            ElseIf rng.Cells(row, col).value = rng.Cells(row, col + 1).value Then
                serial = serial + 1
            ElseIf serial > 0 Then
                Range(rng.Cells(row, col - serial), rng.Cells(row, col)).Merge
                serial = 0
            Else
                serial = 0
            End If
        Next col
    
        If serial > 0 Then Range(rng.Cells(row, col - serial), rng.Cells(row, col)).Merge
    Next row
    
    Application.DisplayAlerts = dr
End Function
'▲▲▲ レンジ関連 ▲▲▲



'▼▼▼ 文字列操作関連 ▼▼▼
'機能:文字列の正規表現に一致するパターンをすべて取得する
'引数1:文字列
'引数2:パターン(正規表現)
'戻り値:string配列
'参照ライブラリ:Microsoft VBScript Regular Expressions 5.5
Public Function SearchPattern(ByVal val As String, ByVal pattern As String) As Collection
    
    Set SearchPattern = New Collection
    
    Dim reg As New RegExp
    reg.pattern = pattern
    reg.IgnoreCase = True '大文字と小文字を区別するように設定します。
    reg.Global = True     '文字列全体を検索

    Dim mc As IMatchCollection2
    Set mc = reg.Execute(val)
    
    If mc.Count = 0 Then Exit Function
    
    Dim cnt As Long
    For cnt = 1 To mc.Count
        Call SearchPattern.add(mc.item(cnt - 1).value)
    Next cnt
End Function

Public Function MatchPattern(ByVal val As String, ByVal pattern As String) As Boolean
    MatchPattern = (SearchPattern(val, pattern).Count > 0)
End Function

'機能:Split関数の改造版 インデックスの指定とゴミ(分割後のTrim後0文字データ)の除去
'引数1:文字列
'引数2:区切り文字
'引数3:最大分割数(指定なし:制限なし)
'引数4:比較モード(指定なし:vbBinaryCompare)
'引数5:インデックス開始番号(指定なし:1)
'引数6:行末行頭のスペースや改行を除去し、文字数が0の要素を除外するか(指定なし:しない)
'戻り値:分割後文字列
Public Function SplitEx(ByVal val As String, ByVal delimiter As String _
                      , Optional ByVal limit As Long = -1, Optional ByVal compare As Long = vbBinaryCompare _
                      , Optional ByVal start_index As Long = 1, Optional ByVal reject As Boolean = False) As String()
    Dim res() As String
    If Len(val) = 0 Then
        Exit Function
    ElseIf InStr(val, delimiter) = 0 Then
        ReDim res(start_index To start_index)
        res(start_index) = val
    Else
        Dim spt() As String
        spt = Split(val, delimiter, limit, compare)
        
        Dim tmp As String
        Dim cnt As Long
        Dim eCnt As Long
        For eCnt = LBound(spt) To UBound(spt)
            tmp = spt(eCnt)
            If reject Then tmp = TrimEx(tmp)
            If reject = False Or Len(tmp) > 0 Then
                
                If cnt = 0 Then
                    ReDim res(start_index To start_index)
                Else
                    ReDim Preserve res(start_index To start_index + cnt)
                End If
                
                res(start_index + cnt) = tmp
                cnt = cnt + 1
            End If
        Next eCnt
    End If
    
    SplitEx = res
End Function

'機能:Trim関数の改造版 行頭,行末の改行コードも削除する
'引数1:文字列
'戻り値:行頭,行末の改行コード削除後の文字列
Public Function TrimEx(ByVal val As String) As String
    Dim tmp As String
    
    tmp = Trim(val)
    tmp = RejectHead(tmp, vbCrLf)
    tmp = RejectTail(tmp, vbCrLf)
    tmp = RejectHead(tmp, vbCr)
    tmp = RejectTail(tmp, vbCr)
    tmp = RejectHead(tmp, vbLf)
    tmp = RejectTail(tmp, vbLf)

    TrimEx = tmp
End Function

'機能:行頭の指定文字を削除する
'引数1:文字列
'引数2:指定文字
'戻り値:行頭に一致する指定文字削除後の文字列
Public Function RejectHead(ByVal val As String, ByVal key As String) As String

    Dim tmp As String
    tmp = val
    
    Do While tmp Like "*" & key
        tmp = Mid(tmp, Len(key) + 1, Len(tmp) - Len(key))
    Loop
    
    RejectHead = tmp
End Function

'機能:行末の指定文字を削除する
'引数1:文字列
'引数2:指定文字
'戻り値:行末に一致する指定文字削除後の文字列
Public Function RejectTail(ByVal val As String, ByVal key As String) As String

    Dim tmp As String
    tmp = val
    
    Do While tmp Like key & "*"
        tmp = Mid(tmp, 1, Len(tmp) - Len(key))
    Loop
    
    RejectTail = tmp
End Function

'メタ文字を削除する
Public Function MetaString(ByVal moto As String) As String
    Dim res As String
    
    Dim cnt As Long
    Dim isPtn As Boolean
    Dim s As String
    For cnt = 1 To Len(moto)
        s = Mid(moto, cnt, 1)
        If s = "<" Then
            isPtn = True
        End If
        
        If isPtn Then
            res = res & s
        Else
            Select Case s
                Case "(", ")", "+", "^", "$", "\", "." 'メタ文字対策
                    res = res & "\" & s
                Case Else
                    res = res & s
            End Select
        End If
        
        If s = ">" Then
            isPtn = False
        End If
    Next cnt
    
    MetaString = res
End Function

'指定した文字の連続した文字列を作成する
'引数1:文字列
'引数2:連続する回数
Public Function StringEx(ByVal number As Long, ByVal val As String) As String
    Dim cnt As Long
    For cnt = 1 To number
        StringEx = StringEx & val
    Next cnt
End Function

'値が空白の場合、指定した文字列に置き換える
'引数1:元の値
'引数2:空白を置き換える文字列
Public Function ShowBlank(ByVal mSG As String, Optional ByVal vBlank As String = "【空白】") As String
    ShowBlank = IIf(Len(mSG) = 0, vBlank, mSG)
End Function

'プロシージャ文字列を作成する
'引数1:プロシージャ名
'引数2～10:引数1～9
Public Function MakeProcedureString(ByVal pName As String, _
                                    Optional ByVal arg1 As Variant = Empty, _
                                    Optional ByVal arg2 As Variant = Empty, _
                                    Optional ByVal arg3 As Variant = Empty, _
                                    Optional ByVal arg4 As Variant = Empty, _
                                    Optional ByVal arg5 As Variant = Empty, _
                                    Optional ByVal arg6 As Variant = Empty, _
                                    Optional ByVal arg7 As Variant = Empty, _
                                    Optional ByVal arg8 As Variant = Empty, _
                                    Optional ByVal arg9 As Variant = Empty)
    MakeProcedureString = "'" & pName
    If Not IsEmpty(arg1) Then MakeProcedureString = MakeProcedureString & " " & """" & arg1 & """"
    If Not IsEmpty(arg2) Then MakeProcedureString = MakeProcedureString & " " & """" & arg2 & """"
    If Not IsEmpty(arg3) Then MakeProcedureString = MakeProcedureString & " " & """" & arg3 & """"
    If Not IsEmpty(arg4) Then MakeProcedureString = MakeProcedureString & " " & """" & arg4 & """"
    If Not IsEmpty(arg5) Then MakeProcedureString = MakeProcedureString & " " & """" & arg5 & """"
    If Not IsEmpty(arg6) Then MakeProcedureString = MakeProcedureString & " " & """" & arg6 & """"
    If Not IsEmpty(arg7) Then MakeProcedureString = MakeProcedureString & " " & """" & arg7 & """"
    If Not IsEmpty(arg8) Then MakeProcedureString = MakeProcedureString & " " & """" & arg8 & """"
    If Not IsEmpty(arg9) Then MakeProcedureString = MakeProcedureString & " " & """" & arg9 & """"
    MakeProcedureString = MakeProcedureString & "'"
End Function

Public Function TextSplit2Collection(ByVal txt As String, ByVal delimiter As String, Optional ByVal DuplicateDelete As Boolean = False) As Collection
    Set TextSplit2Collection = New Collection
    If InStr(txt, delimiter) = 0 Then
        txt = TrimEx(txt)
        If Len(txt) > 0 Then Call TextSplit2Collection.add(txt)
        Exit Function
    End If
    
    Dim spt() As String
    spt = SplitEx(txt, delimiter, reject:=False)
    
    Dim cnt As Long, v As String, dic As New Scripting.Dictionary
    For cnt = LBound(spt) To UBound(spt)
        v = spt(cnt)
        v = TrimEx(v)
        If Len(v) > 0 Then
            Call TextSplit2Collection.add(spt)
            Call DicAddEx(dic, v)
        Else
            
        End If
    Next cnt
    
    If DuplicateDelete Then Set TextSplit2Collection = Key2Collection(dic)
End Function
'▲▲▲ 文字列操作関連 ▲▲▲



'▼▼▼ 装飾系 ▼▼▼
'機能:オートシェイプをテンプレートから作成する
'引数1:出力先ワークシート
'引数2:文字列
'引数3:元にするオートシェイプ
'戻り値:オートシェイプ
Public Function MakeAutoShape(ByVal ws As Worksheet, ByVal txt As String, ByRef ref As Shape) As Shape
    ref.PickUp
    
    Dim tmp As Shape
    Set tmp = ws.Shapes.AddShape(msoShapeRectangle, 0, 0, 10, 10)
    
    tmp.Apply
    tmp.TextFrame.Characters.Text = txt
    If Len(txt) > 0 Then
        tmp.TextFrame.AutoSize = True
        tmp.TextFrame.AutoSize = False
    End If
    
    tmp.height = ref.height
    
    If IsNumeric(txt) = True Then
        tmp.TextFrame.HorizontalAlignment = xlHAlignRight
    End If
    
    Set MakeAutoShape = tmp
End Function

'機能:セルの一部の文字フォーマットを変更する
'引数1:セル範囲
'引数2:変更開始位置
'引数3:変更長さ
'引数4:文字色(省略時：黒)
'引数5:太字(省略時：False)
'引数6:イタリック(省略時：False)
'コメント:数値セルはうまくいかない
Public Function SetEmphasis(ByRef rng As Range, ByVal start_ As Long, ByVal len_ As Long, Optional ByVal color As Long = vbBlack, Optional ByVal isBold As Boolean = True, Optional ByVal isitalic As Boolean = False)
    Dim rom As sOperationMode: rom = RecordOperationMode
    SilentMode
    
    With rng.Characters(Start:=start_, Length:=len_).Font
        .color = color
        .Bold = isBold
        .Italic = isitalic
    End With
    
    Call SetOperationMode(rom)
End Function

'機能:セルのキーワードに一致する文字の文字フォーマットを変更する
'引数1:セル範囲
'引数2:キーワード
'引数3:文字色(省略時：黒)
'引数4:太字(省略時：False)
'引数5:イタリック(省略時：False)
'コメント:数値セルはうまくいかない
Public Function SetEmphasisByKey(ByRef rng As Range, ByVal key As String, Optional ByVal color As Integer = vbBlack, Optional ByVal isBold As Boolean = True, Optional ByVal isitalic As Boolean = False)
    Dim c As Range
    Dim spt() As String
    Dim sptCnt As Long
    Dim chrCnt As Long
    Dim isHead As Boolean
    Dim isTail As Boolean
    
    For Each c In rng
        isHead = Left(c.value, Len(key)) = key
        isTail = Right(c.value, Len(key)) = key
        chrCnt = 1
        
        If InStr(c, key) > 0 Then
            spt = Split(c.value, key)
            If UBound(spt) - LBound(spt) = 1 Then
                Call SetEmphasis(c, InStr(c.value, key), Len(key), color, isBold, isitalic)
            Else
                If isHead Then Call SetEmphasis(c, 0, Len(key), color, isBold, isitalic)
                For sptCnt = LBound(spt) To UBound(spt)
                    chrCnt = chrCnt + Len(spt(sptCnt))
                    If sptCnt < UBound(spt) Then
                        Call SetEmphasis(c, chrCnt, Len(key), color, isBold, isitalic)
                        chrCnt = chrCnt + Len(key)
                    End If
                Next sptCnt
                If isHead Then Call SetEmphasis(c, chrCnt, Len(key), color, isBold, isitalic)
            End If
        End If
    Next c
End Function
'▲▲▲ 装飾系 ▲▲▲



'▼▼▼ メンテナンス/デバッグ系 ▼▼▼
'全モジュールをソースファイルに保存する
Public Sub ソース出力()
    Call ExportModule
End Sub

'すべての名前定義を表示状態にする
Public Sub 名前定義全表示()
    Dim name As Object
    For Each name In names
        If Not name.Visible Then name.Visible = True
    Next
    MsgBox "すべての名前の定義を表示しました。", vbOKOnly
End Sub

'指定した時間処理を止める
'引数1:処理を止める時間(単位:マイクロ秒)
Public Function USleep(ByVal usec As Long)
    Call Sleep(usec / 1000)
End Function

'機能:マクロ付エクセルファイルから全モジュールをエクスポートする
'引数1:出力対象プロジェクト
'引数2:出力先ディレクトリ
'備考:この関数は Microsoft Visual Basic for ApplicationsExtensibility *.* を使用しています
Private Function ExportModule(Optional ByVal target_project As String, Optional ByVal output_dir As String)
    If Len(target_project) = 0 Then target_project = ThisWorkbook.FullName
    If Len(output_dir) = 0 Then
        output_dir = ThisWorkbook.path & "\src\"
        Call MkDir(output_dir)
    End If
    
    Dim output_file As String

    Dim pCnt As Long, ccnt As Long
    For pCnt = 1 To Application.VBE.VBProjects.Count
        If Application.VBE.VBProjects(pCnt).FileName <> target_project Then GoTo NextProject
        
        For ccnt = 1 To Application.VBE.VBProjects(pCnt).VBComponents.Count
            If Application.VBE.VBProjects(pCnt).VBComponents(ccnt).CodeModule.CountOfLines = 0 Then GoTo NextModule
            Select Case Application.VBE.VBProjects(pCnt).VBComponents(ccnt).Type
                Case vbext_ct_StdModule, vbext_ct_Document: output_file = Application.VBE.VBProjects(pCnt).VBComponents(ccnt).name & ".bas"
                Case vbext_ct_ClassModule:                  output_file = Application.VBE.VBProjects(pCnt).VBComponents(ccnt).name & ".cls"
                Case vbext_ct_MSForm:                       output_file = Application.VBE.VBProjects(pCnt).VBComponents(ccnt).name & ".frm"
                Case Else:                                  output_file = Application.VBE.VBProjects(pCnt).VBComponents(ccnt).name & ".txt"
            End Select
            Call Application.VBE.VBProjects(pCnt).VBComponents(ccnt).Export(output_dir & output_file)
NextModule:
        Next ccnt
NextProject:
    Next pCnt
End Function

'機能:使用できるメモリを取得する
'戻り値:利用可能メモリ(MByte)
Public Function GetFreeMemory() As Long
    Dim MemData As MEMORYSTATUS
    Call GlobalMemoryStatus(MemData)
    GetFreeMemory = MemData.dwAvailVirtual / 1000000
 End Function
'▲▲▲ メンテナンス/デバッグ系 ▲▲▲



'▼▼▼ 改良系 ▼▼▼
'四捨五入
Public Function ExRound(ByVal i_val As Double, Optional ByVal i_num As Long = 0) As Double
    ExRound = Int(i_val * (10 ^ i_num) + 0.5) / 10 ^ i_num
End Function


'一次元配列の場合の辞書にItemを追加する
'引数1:辞書
'引数2:Key
'引数3:増やしたいItem
Public Function DicAppendArrayItem(ByRef dic As Scripting.Dictionary, ByVal key As Variant, ByVal additem As Variant)
    Dim tmp As Variant
    If dic.Exists(key) Then
        tmp = dic.item(key)
        If Not IsArray(tmp) Then Err.Raise ERROR_CODE, "実装ミス", "アイテムが配列ではありません"
        Call dic.remove(key)
        ReDim Preserve tmp(UBound(tmp) + 1) As Variant
        tmp(UBound(tmp)) = additem
        Call DicAddEx(dic, key, tmp)
    Else
        Call DicAddEx(dic, key, Array(additem))
    End If
End Function
'▲▲▲ 改良系 ▲▲▲



'定番処理


Public Function JoinEx(ByVal arr As Variant, ByVal delimiter As String) As String
    If IsEmpty(arr) Then Exit Function
    
    Dim cnt As Long
    For cnt = LBound(arr) To UBound(arr)
        If Len(CStr(arr(cnt))) > 0 Then
            JoinEx = IIf(Len(JoinEx) = 0, "", JoinEx & delimiter) & arr(cnt)
        End If
    Next cnt
End Function

Public Function ConvertDate(ByVal str As String, ByVal format As String) As Date
    Dim tmp As String
    
    Dim cnt As Long, ref_cnt As Long
    ref_cnt = 1
    For cnt = 1 To Len(format)
        If Mid(format, cnt, 1) = "*" Then
            tmp = tmp & Mid(str, ref_cnt, 1)
            ref_cnt = ref_cnt + 1
        Else
            tmp = tmp & Mid(format, cnt, 1)
        End If
    Next cnt
    
    If IsDate(tmp) Then ConvertDate = CDate(tmp)
End Function

Public Function Range2Address(ByRef rng As Range, Optional ByVal isR1C1 As Boolean = False) As String
    Range2Address = "'" & rng.Parent.name & "'!" & rng.address(ReferenceStyle:=IIf(isR1C1, xlR1C1, xlA1))
End Function


Public Function SearchRowTailAll(ByRef ws As Worksheet, ByVal ref As Long) As Long
    Dim cTail As Long
    cTail = smCommon.SearchColTail(ws, ref)
    
    Dim cnt As Long
    ReDim arr(1 To cTail) As Long
    For cnt = 1 To cTail
        arr(cnt) = smCommon.SearchRowTail(ws, cnt)
    Next cnt
    
    SearchRowTailAll = WorksheetFunction.max(arr)
End Function

Property Get NearColor() As Long
    NearColor = eColorIndex.Orange
End Property

'このモジュールで使用している参照設定を追加する
Sub AddReferences()
    Call AddReference("{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0) 'Microsoft Scripting Runtime(Scripting.Dictionaryなど)
    Call AddReference("{3F4DACA7-160D-11D2-A8E9-00104B365C9F}", 5, 5) 'Microsoft VBScript Regular Expressions 5.5(正規表現など)
    Call AddReference("{0002E157-0000-0000-C000-000000000046}", 5, 3) 'Microsoft Visual Basic for Applications Extensibility 5.3(ソース出力用)
End Sub

'参照設定を追加する
Private Function AddReference(ByVal guid As String, ByVal major As Long, ByVal minor As Long)
On Error GoTo Exp
    Call ActiveWorkbook.VBProject.References.AddFromGuid(guid, major, minor)
    Exit Function
Exp:
    
    If Err.number = 32813 Then
        Debug.Print guid & "は既に追加されています"
        Err.Clear
    Else
        Dim code As Long, src As String, dsc As String
        code = Err.number
        src = Err.Source
        dsc = Err.Description
        
        On Error GoTo 0
        Err.Raise code, src, dsc
    End If
End Function

'現在の参照設定を追加するコードを出力する
Sub ShowRefer()
    Dim cnt As Long, ref As Reference
    For cnt = 1 To ActiveWorkbook.VBProject.References.Count
        Set ref = ActiveWorkbook.VBProject.References(cnt)
'        Debug.Print (vbTab & "'" & ref.Description)
'        Debug.Print (vbTab & "Call ActiveWorkbook.VBProject.References.AddFromGuid(""" _
'                           & ref.guid _
'                           & """ ," _
'                           & ref.major _
'                           & " ," _
'                           & ref.minor _
'                           & ")")
'        Debug.Print (vbTab & "'" & ref.Description)
        Debug.Print (vbTab & "Call AddReference(""" _
                           & ref.guid _
                           & """ ," _
                           & ref.major _
                           & " ," _
                           & ref.minor _
                           & ")" _
                           & "'" & ref.Description)
    Next
End Sub

'複数セルに一つの値をセットする
Public Function SetSingleValue(ByRef target As Range, ByVal val As Variant, _
                                Optional ByVal format As String = "")
    If Len(format) > 0 Then target.NumberFormatLocal = format
    target.value = val
End Function