LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@fh0523

smCommon

Posted at

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:flag_mm:ss") + " " + Message
If isDebugPrint Then Debug.Print format(Now, "yyyy/MM/dd hh:flag_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

0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?