''===== ThisWorkbookモジュール ===== 'Private Sub Workbook_Open() ' Set cM = SourceOfAddin.GetClass 'End Sub ' 'Private Sub Workbook_BeforeClose(Cancel As Boolean) ' Set cM = Nothing 'End Sub ''===== ThisWorkbookモジュールここまで ===== Option Explicit Public cM As cMain Private cMn As cMenu
'●ボタンを並べるだけの簡単なメニュー
Private Sub AddMenu()
Set cMn = cM.MenuClass 'メニュークラスのインスタンス生成
With cMn
Set .wbAddin = ThisWorkbook 'このアドインブック
.AppliName = "myProject" 'このアドインブックのオブジェクト名
.AppliCaption = "myCaption" '主にMsgboxのCaptionに使用
.MenuCaption = "メニュー名" '★追加メニュー名
'★親コマンドバーの指定（名前を指定する例）
.ParentBarName = "Worksheet Menu Bar"
'★ボタンの追加
.AddButton("メニュー1", False).OnAction = "Module1.Menu1" 'ボタンの追加＆実行プロシージャの指定
.AddButton("メニュー2", False).OnAction = "Module1.Menu2"
.AddButton("メニュー3", True).OnAction = "Module1.Menu3" 'True は区切り線
.AddButton("メニュー4", False).OnAction = "Module1.Menu4"
End With
End Sub
'●階層メニュー
Private Sub AddMenu2()
Set cMn = cM.MenuClass 'メニュークラスのインスタンス生成
With cMn
Set .wbAddin = ThisWorkbook 'このアドインブック
.AppliName = "myProject" 'このアドインブックのオブジェクト名
.AppliCaption = "myCaption" '主にMsgboxのCaptionに使用
.MenuCaption = "メニュー名" '★追加メニュー名
'★親コマンドバーの指定（名前を指定する例）
.ParentBarName = "Worksheet Menu Bar"
'★階層メニューの設定
With .AddPopup("サブメニューA") 'ポップアップの追加
.AddButton("SubMenuA-1").OnAction = "Module1.Menu1" 'ボタンの追加
.AddButton("SubMenuA-2").OnAction = "Module1.Menu2"
End With
With .AddPopup("サブメニューB") 'ポップアップの追加
.AddButton("SubMenuB-1").OnAction = "Module2.Menu1" 'ボタンの追加
.AddButton("SubMenuB-2").OnAction = "Module2.Menu2"
End With
End With
End Sub
'●その日は祝日か
Private Sub IsHoliday()
Const D As Date = #5/6/2013#
Dim Note As String '祝日名を受け取る変数
Dim cCal As cCalendar
Set cCal = cM.CalendarClass
If cCal.IsHoliday(D, Note) Then '<===★★★ ここ ★★★
MsgBox Note, vbInformation
Else
MsgBox "祝日ではありません。", vbExclamation
End If
Set cCal = Nothing
End Sub
'●指定期間のカレンダー配列取得
Private Sub CalendarAry()
Dim cCal As cCalendar
Const bDay As Date = #4/1/2013#
Const eDay As Date = #3/31/2014#
Dim Cals As Variant
Set cCal = cM.CalendarClass
Cals = cCal.CalendarAry(bDay, eDay) '<===★★★ ここ ★★★
'新規ブックに書き出し
With Workbooks.Add.Worksheets(1)
.Range("A1").Resize(UBound(Cals) + 1, 4).Value = Cals '(日付,曜日,祝日名|備考,H|U|HU|"")
.UsedRange.EntireColumn.AutoFit
.Parent.Saved = True
End With
Set cCal = Nothing
End Sub
'●単独で日付を取得（ユーザー入力、ウィザードの中などで使用）
Private Sub CalendarForm()
Dim cCal As cCalendar
Set cCal = cM.CalendarClass
With cCal
.Value = #10/12/2020# '初期日付
If .Show Then 'カレンダー表示 '<===★★★ ここ ★★★
MsgBox Format$(.Value, "yyyy/mm/dd"), vbInformation '<===★★★ ここ ★★★
Else
MsgBox "Cancel", vbExclamation
End If
End With
Set cCal = Nothing
End Sub
'●指定期間のカレンダーシート作成
Private Sub CreateCalendarSheet()
Const FirstDay As Long = 16 '15日〆
Const BeginDate As Date = #3/16/2013# '期間開始日
Const EndDate As Date = #3/15/2014# '期間終了日
Dim cCal As cCalendar
Dim ShtCount As Long
Dim myBook As Workbook
Dim R As Range
Dim i As Long
Dim Days As Variant
Dim Bd As Date, Ed As Date
Dim C As Long
Dim cFc As cFunction
Set cCal = cM.CalendarClass
'新規ブック作成
ShtCount = DateDiff("m", BeginDate, EndDate) + 1
If VBA.Day(EndDate) <= FirstDay Then ShtCount = ShtCount - 1
Dim cWb As cGetWorkbook
Set cWb = cM.GetWorkbookClass
Set myBook = cWb.CreateNewBook(ShtCount)
Set cWb = Nothing
Bd = BeginDate: If VBA.Day(Bd) < FirstDay Then Bd = DateSerial(VBA.Year(Bd), VBA.Month(Bd), FirstDay)
Ed = DateSerial(VBA.Year(Bd), VBA.Month(Bd) + 1, FirstDay - 1)
If Ed > EndDate Then Ed = EndDate
Do
Days = cCal.CalendarAry(Bd, Ed) '(日付,曜日,祝日名|備考,H|U|HU|"") '<===★★★ ここ ★★★
C = C + 1
Set R = myBook.Worksheets(C).Range("A2") 'シート上の日付表示起点
For i = LBound(Days) To UBound(Days)
'日付
R.Value = Days(i, 0): R.NumberFormatLocal = "m/d"
'曜日
R.Offset(, 1).Value = Days(i, 1)
'土、日、祝日色
If Days(i, 1) = "日" Or Days(i, 3) = "H" Or Days(i, 3) = "HU" Then
R.Resize(, 2).Font.Color = vbRed
ElseIf Days(i, 1) = "土" Then
R.Resize(, 2).Font.Color = vbBlue
End If
'ユーザー定義休日
If Days(i, 3) = "U" Or Days(i, 3) = "HU" Then R.Resize(, 2).Font.Bold = True
'祝日名、ユーザー定義休日の備考
If Days(i, 3) <> "" Then
With R.AddComment(Days(i, 2))
.Shape.TextFrame.AutoSize = True
End With
End If
Set R = R.Offset(1)
Next
R.Worksheet.UsedRange.EntireColumn.AutoFit
R.Worksheet.Name = Format$(Ed, "ge年m月度") 'シート名
Bd = Ed + 1
Ed = DateSerial(VBA.Year(Bd), VBA.Month(Bd) + 1, FirstDay - 1)
If Ed > EndDate Then Ed = EndDate
Loop Until Bd > EndDate
Set cCal = Nothing
End Sub
'●ファイルリスト（マイドキュメント直下のxlsファイルのフルネームリストを新規シートに表示）
Private Sub FileList()
Dim cFlist As cFileList
Dim myPath As String
Set cFlist = cM.FileListClass
With cFlist
.SearchPattern = "*.xls"
myPath = .MyDocumentsPath
If .Execute(myPath) Then
If .Count >= 1 Then
'新規ブックに表示
Workbooks.Add.Worksheets(1).Range("A1").Resize(.Count).Value _
= .Transpose2(.FullNames)
ActiveWorkbook.Saved = True
End If
End If
End With
Set cFlist = Nothing
End Sub
'●ファイルリスト2（パターンの複数指定とソート、フルネームリストを新規シートに表示）
Private Sub FileList2()
Dim cFlist As cFileList2
Dim myPath As String
Set cFlist = cM.FileList2Class
With cFlist
.SearchPattern = "*.xls;*.xla" '複数指定可
myPath = .MyDocumentsPath
If .Execute(myPath, msoSortByFileName) Then 'ソート指定可
If .Count >= 1 Then
'新規ブックに表示
Workbooks.Add.Worksheets(1).Range("A1").Resize(.Count).Value _
= .Transpose2(.FullNames)
ActiveWorkbook.Saved = True
End If
End If
End With
Set cFlist = Nothing
End Sub
'●ファイルサーチ代替クラス使用例
Private Sub FileSearchLight()
Dim cFs As cFileSearchLight
Dim i As Long
Dim R As Range
Set cFs = New cFileSearchLight
With cFs
.LookIn = .MyDocumentsPath 'マイドキュメントパス
.SearchSubFolders = True
.FileName = "*.xls;*.xla"
If .Execute >= 1 Then
'新規ブックに書き出し
Set R = Workbooks.Add.Worksheets(1).Range("A1")
For i = 1 To .FoundFilesCount
R.Value = .FoundFiles(i) 'フルパス
R.Offset(, 1).Value = .Fnames(i) 'ファイル名のみ
Set R = R.Offset(1)
Next
ActiveWorkbook.Saved = True
End If
End With
Set cFs = Nothing
End Sub
'●年齢
Private Sub Age()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.Age(BirthDay:=#6/3/2000#, PointDay:=Date) & "歳"
Set cFn = Nothing
End Sub
'●月の最終日
Private Sub EndDay()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.EndDay(Nen:=2012, Getsu:=2)
Set cFn = Nothing
End Sub
'●第ｎ月曜日（ｘ曜日）
Private Sub NthWeek()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.NthWeek(Y:=2013, M:=6, N:=2, DayOfWeek:=vbMonday)
Set cFn = Nothing
End Sub
'●カレンダーフォームによるセルへの日付入力
Private Sub DateInput()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
cFn.DateInput Target:=ActiveCell, StaticMode:=False, InitialDate:=Date
Set cFn = Nothing
End Sub
'●配列の次元
Private Sub Dimension()
Dim cFn As cFunction
Dim V As Variant
Dim A()
Set cFn = cM.FunctionClass
V = Array(1, 2, 3)
Debug.Print cFn.Dimension(V) '一次元 ==>1
V = Range("A1:B5").Value
Debug.Print cFn.Dimension(V) '二次元 ==>2
Debug.Print
Debug.Print cFn.Dimension(2) '配列以外 ==>0
Debug.Print cFn.Dimension(A) '未初期化 ==>-1
Debug.Print
ReDim A(1 To 2)
Debug.Print cFn.Dimension(A) '一次元 ==>1
Erase A
Debug.Print cFn.Dimension(A) '未初期化 ==>-1
Debug.Print
ReDim V(1 To 2)
Debug.Print cFn.Dimension(V) '一次元 ==>1
Erase V
Debug.Print cFn.Dimension(V) '未初期化 ==>-1
V = Empty
Debug.Print cFn.Dimension(V) '配列以外 ==>0
Set cFn = Nothing
End Sub
'●未初期化配列、空配列、通常配列の確認
Private Sub IsZeroAry()
Dim cFn As cFunction
Dim V() As Long
Set cFn = cM.FunctionClass
MsgBox cFn.IsEmptyAry(V)
MsgBox cFn.IsZeroAry(Array())
MsgBox cFn.IsNormalAry(Array(1, 2))
Set cFn = Nothing
End Sub
'●配列結合
Private Sub JoinAry()
Dim cFn As cFunction
Dim Ary1, Ary2, V
Set cFn = cM.FunctionClass
Ary1 = Array(2, 3)
Ary2 = Array(0, 1, 2)
Ary1 = cFn.JoinAry(Ary1, Ary2)
For Each V In Ary1
Debug.Print V;
Next
Debug.Print
Set cFn = Nothing
End Sub
'●配列の切り出し（行範囲、列範囲指定）
Private Sub CutAry()
Dim cFn As cFunction
Dim VV As Variant
Set cFn = cM.FunctionClass
VV = cFn.CutAry(Ary:=Selection.Value, RowL:=2, RowU:=5, ColumnL:=2, ColumnU:=3)
Debug.Print "左上"; VV(0, 0), "右下"; VV(5 - 2, 3 - 2)
Set cFn = Nothing
End Sub
'●２次元配列の後方カット（行方向のResize）
Private Sub CutTail()
Dim cFn As cFunction
Dim VV As Variant
Set cFn = cM.FunctionClass
VV = cFn.CutTail(Ary:=Selection.Value, LastRow:=10)
MsgBox "右下：" & VV(UBound(VV), UBound(VV, 2))
Set cFn = Nothing
End Sub
'●セル範囲を【テキスト】で取得
Private Sub RangeText()
Dim cFn As cFunction
Dim VV
Set cFn = cM.FunctionClass
VV = cFn.RangeText(Rng:=Selection)
MsgBox VV(1, 1)
MsgBox TypeName(VV(1, 1))
Set cFn = Nothing
End Sub
'●二次元配列をカンマ区切りの一次元配列に
Private Sub JoinRows()
Dim cFn As cFunction
Dim VV, V
Set cFn = cM.FunctionClass
VV = cFn.JoinRows(Ary2:=Selection.Value, Delimiter:=",")
For Each V In VV
Debug.Print V
Next
Set cFn = Nothing
End Sub
'●カンマ区切りの一次元配列を二次元配列に
Private Sub SplitRows()
Dim cFn As cFunction
Dim V(1 To 2) As String
Dim VV As Variant
Dim i As Long, j As Long
Set cFn = cM.FunctionClass
V(1) = "1,2,3,4,5"
V(2) = "a,b,c,d,e"
VV = cFn.SplitRows(Ary1:=V)
For i = LBound(VV) To UBound(VV)
For j = LBound(VV, 2) To UBound(VV, 2)
Debug.Print VV(i, j);
Next: Debug.Print
Next: Debug.Print
Debug.Print
Set cFn = Nothing
End Sub
'●Range（セル範囲）から重複の無い一次元配列取得
Private Sub Summary()
Dim cFn As cFunction
Dim VV, V
Set cFn = cM.FunctionClass
VV = cFn.Summary(Selection)
For Each V In VV
Debug.Print V
Next
Set cFn = Nothing
End Sub
'●乱配列（指定範囲の重複の無い乱配列を返す。インデックスは１から。ex. 指定範囲=5〜10 ==> {8,10,6,5,7,9}）
Private Sub RandAry()
Dim cFn As cFunction
Dim A As Variant
Dim V As Variant
Set cFn = cM.FunctionClass
A = cFn.RandAry(L:=5, U:=10)
For Each V In A
Debug.Print V;
Next: Debug.Print
Set cFn = Nothing
End Sub
'●フォルダの選択
Private Sub SelectFolder()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.SelectFolder2
Set cFn = Nothing
End Sub
'●親フォルダ名
Private Sub MasterDir()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox CurDir
MsgBox cFn.MasterDir(CurDir)
Set cFn = Nothing
End Sub
'●ファイル名、拡張子、などをフルパスから取得
Private Sub FileName()
Dim cFn As cFunction
Const FullPath As String = "c:\data\test.txt"
Set cFn = cM.FunctionClass
MsgBox cFn.FileName(FullPath) '==>test.txt
MsgBox cFn.Extension(FullPath) '==>.txt
MsgBox cFn.FileNameOnly(FullPath) '==>test
Set cFn = Nothing
End Sub
'●デスクトップパス
Public Function DeskTopPath() As String
Dim cFn As cFunction
Set cFn = cM.FunctionClass
DeskTopPath = cFn.DeskTopPath
Set cFn = Nothing
End Function
'●マイドキュメントパス
Private Sub MyDocumentsPath()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.MyDocumentsPath
Set cFn = Nothing
End Sub
'●ワークシートN枚のブックを新規に作成
Private Sub CreateNewBook()
Dim cFn As cFunction
Dim Wb As Workbook
Set cFn = cM.FunctionClass
Set Wb = cFn.CreateNewBook(2)
MsgBox Wb.Name
Set Wb = Nothing
Set cFn = Nothing
End Sub
'●シート名として使用可能かどうか
Private Sub IsCorrectSheetName()
Dim cFn As cFunction
Const Namae As String = "Sheet1"
Dim Msg As String
Set cFn = cM.FunctionClass
If cFn.IsCorrectSheetName(Namae, Msg) Then
MsgBox "ok", vbInformation
Else
MsgBox Msg, vbExclamation
End If
Set cFn = Nothing
End Sub
'●シートの存在有無
Private Sub ExistSheet()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.ExistSheet("sheet1")
MsgBox cFn.ExistSheet("ＳＨＥＥＴ１")
Set cFn = Nothing
End Sub
'●次のシート名（BaseNameと同名シートが存在する時、_1, _2, ... と、次に使用できる名前を返す）
Private Sub NextShtName()
'★★★★★ ※実行注意：アクティブブックにシートが挿入されます。 ★★★★★
Dim cFn As cFunction
Dim shtBase As Worksheet
Dim i As Integer
Set cFn = cM.FunctionClass
'ベースシート
Set shtBase = ActiveWorkbook.Worksheets("sheet1")
'ベースシートをコピー
For i = 1 To 5
shtBase.Copy after:=shtBase
Next
'コピーしたシートの名前変更
With shtBase
For i = 1 To 5
.Parent.Worksheets(.Index + i).Name = cFn.NextShtName(BaseName:=.Name) '<===★★★ ここ ★★★
Next
End With
Set cFn = Nothing
End Sub
'●セル範囲選択（ユーザーが指定したセル範囲をそのまま受け取る）
Private Sub SelectRange()
Dim cFn As cFunction
Dim Ret As Range
Set cFn = cM.FunctionClass
If cFn.SelectRange(Rng:=Ret) Then '<===★★★ ここ ★★★
MsgBox Ret.Address, vbInformation
Else
MsgBox "Cancel", vbExclamation
End If
Set cFn = Nothing
End Sub
'●セルデータ範囲選択（ユーザーの指定と【入力済のデータ範囲】を勘案したセル範囲を受け取る）
Private Sub SelectRangeData()
Dim cFn As cFunction
Dim Ret As Range
Set cFn = cM.FunctionClass
If cFn.SelectRangeData(Rng:=Ret) Then '<===★★★ ここ ★★★
MsgBox Ret.Address, vbInformation
Else
MsgBox "Cancel", vbExclamation
End If
Set cFn = Nothing
End Sub
'●単一セル選択（ユーザーに単一セルを選択させる）
Private Sub SelectRangeOne()
Dim cFn As cFunction
Dim Ret As Range
Set cFn = cM.FunctionClass
If cFn.SelectRangeOne(Rng:=Ret) Then '<===★★★ ここ ★★★
MsgBox Ret.Address, vbInformation
Else
MsgBox "Cancel", vbExclamation
End If
Set cFn = Nothing
End Sub
'●複数列の最終行(最下行の非表示対応、但しフィルタによる非表示は非対応)
Private Sub BottomRange()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
cFn.BottomRange(Selection).Select
Set cFn = Nothing
End Sub
'●列Trim（空セルを除いた範囲）
Private Sub ColmnTrim()
Dim cFn As cFunction
Dim RR As Range
Set cFn = cM.FunctionClass
Set RR = cFn.ColmnTrim(Selection) '<===★★★ ここ ★★★
If RR Is Nothing Then
MsgBox "Nothing"
Else
RR.Select
End If
Set cFn = Nothing
End Sub
'●結合セルの配列(0ベース)（指定セル範囲内の結合セルの配列取得、無ければ空配列）
Private Sub MergeAreas()
Dim cFn As cFunction
Dim AA As Variant
Dim A As Variant
Dim R As Range
Set cFn = cM.FunctionClass
AA = cFn.MergeAreas(Selection) '<===★★★ ここ ★★★
For Each A In AA
Set R = A
Debug.Print R.Address
Next
Set cFn = Nothing
End Sub
'●"" ==> Empty（空文字列を未初期化値=Empty値に置換え）
Private Sub Repl0LenToEmpty()
Dim cFn As cFunction
Dim C As Long
Set cFn = cM.FunctionClass
C = cFn.Repl0LenToEmpty(Selection) '<===★★★ ここ ★★★
MsgBox C & " 箇所置換えました。"
Set cFn = Nothing
End Sub
'●テーブルアイテム（行項目名,列項目名でセル参照の取得）
Private Sub TableItemSampleData()
Dim RR As Range
'新規ブックにサンプルデータ作成
Set RR = Workbooks.Add.Worksheets(1).Range("B3").Resize(11, 6)
'列項目名
With RR.Offset(, 1).Resize(1, RR.Columns.Count - 1)
.Formula = "=CHAR(65+COLUMN()*2)"
.Value = .Value
End With
'行項目名
With RR.Offset(1).Resize(RR.Rows.Count - 1, 1)
.Formula = "=ROW()*2+1"
.Value = .Value
End With
RR.Worksheet.Parent.Saved = True
End Sub
Private Sub TableItem()
Dim cFn As cFunction
Dim RR As Range, R As Range
'行と列を項目名で指定 '<===★★★ ここ ★★★
Const Rv = 23
Const Cv = "K"
Set RR = ActiveCell.Worksheet.UsedRange
Set cFn = cM.FunctionClass
Set R = cFn.TableItem(RR, Rv, Cv, KeyTypeRow:=ktDouble, KeyTypeColumn:=ktString) '<===★★★ ここ ★★★
If Not R Is Nothing Then
R.Select
R.Interior.Color = vbRed
End If
RR.Worksheet.Parent.Saved = True
Set cFn = Nothing
End Sub
'●大きい方
Private Sub Large()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.Large(5, 4)
MsgBox cFn.Large("A", "a")
Set cFn = Nothing
End Sub
'●小さい方
Private Sub Small()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.Small(5, 4)
MsgBox cFn.Small("A", "a")
Set cFn = Nothing
End Sub
'●有効数字ｎ桁にまるめ
Private Sub SignificantFigures()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.SignificantFigures(12.345, 4)
Set cFn = Nothing
End Sub
'●半角英数字
Private Sub IsAlphaNumeric()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.IsAlphaNumeric("123abc")
MsgBox cFn.IsAlphaNumeric("123あabc")
Set cFn = Nothing
End Sub
'●２バイト文字関数
'（全角を２桁、半角を１桁として扱う文字列関数。LenB, LeftB, RightB, MidB関数を普通の感覚で使えるようにした代用関数）
Private Sub DoubleByteString()
Dim cFn As cFunction
Const S As String = "あいabc123う"
Set cFn = cM.FunctionClass
Debug.Print cFn.LenByte(S) '12
Debug.Print cFn.LeftByte(S, 5) 'あいa
Debug.Print cFn.RightByte(S, 3) '3う
Debug.Print cFn.MidByte(S, 3, 3) 'いa
Set cFn = Nothing
End Sub
'●現在実行中の環境が英語環境か日本語環境か
Private Sub Language()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
MsgBox cFn.Language '日本語, English, Other
Set cFn = Nothing
End Sub
'●スリープ（ｎ秒間停止）
Private Sub Sleep1()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
cFn.Sleep1 Seconds:=3
MsgBox "ok"
Set cFn = Nothing
End Sub
'●スリープ（ｎ秒間停止）その２
Private Sub Sleep2()
'停止中のユーザー操作が可能、但し夜中の０時をまたぐ場合は使用不可
Dim cFn As cFunction
Set cFn = cM.FunctionClass
cFn.Sleep2 Seconds:=3, Freeze:=False
MsgBox "ok"
Set cFn = Nothing
End Sub
'●時限付きメッセージボックス
'時間切れ時はTrue(-1)が返る
'×クリック時：Style=vbOKCancelなどで「ｷｬﾝｾﾙ」ボタンがある時 → vbCancel
' Style=vbOKOnlyなどで「OK」ボタンしか無い時 → vbOK
' 「OK」「ｷｬﾝｾﾙ」共に無い時は「×」は無効（淡色表示）
Private Sub Msgbox2()
Dim cFn As cFunction
Set cFn = cM.FunctionClass
cFn.Msgbox2 "3秒で消えます。", vbYesNoCancel + vbDefaultButton2, T:=3
Set cFn = Nothing
End Sub
'●ファイル属性（例：デスクトップのText.txtの属性）
Private Sub GetAtr()
Dim cGA As cGetAttr
Dim myPath As String
myPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\"
Set cGA = cM.GetAttrClass
With cGA
.FullPath = myPath & "test.txt"
Debug.Print "Archive:"; .Archive
Debug.Print "Directory:"; .Directory
Debug.Print "Exist:"; .Exist
Debug.Print "Name:"; .Fname
Debug.Print "Hidden:"; .Hidden
Debug.Print "ReadOnly:"; .ReadOnly
Debug.Print "System:"; .System
Debug.Print
End With
Set cGA = Nothing
End Sub
'●それはファイルか（関数）
Public Function IsFile(FullPath As String) As Boolean
Dim cGA As cGetAttr
Set cGA = cM.GetAttrClass
With cGA
If .Exist(FullPath) Then
If Not .Directory Then
IsFile = True
End If
End If
End With
Set cGA = Nothing
End Function
'●それはフォルダか（関数）
Public Function IsFolder(FullPath As String) As Boolean
Dim cGA As cGetAttr
Set cGA = cM.GetAttrClass
With cGA
If .Exist(FullPath) Then
If .Directory Then
IsFolder = True
End If
End If
End With
Set cGA = Nothing
End Function
'●フォルダ作成（多階層のディレクトリを一気に作成）
Private Sub MakeDir()
Dim cGA As cGetAttr
Dim FullPath As String
Dim Msg As String 'エラー受け取り用
Set cGA = cM.GetAttrClass
FullPath = "C:\test\test2\test3"
If cGA.MakeDir(FullPath, Msg) Then '<===★★★ ここ ★★★
MsgBox "ok", vbInformation
Else
MsgBox Msg, vbExclamation
End If
Set cGA = Nothing
End Sub
'●ブックのオープン＆取得、丁寧版
'（対象ブックが開いていてもいなくても、アクティブであってもなくても、ファイル自体が在ってもなくても、
' とにかく開かれてアクティブになった【ブックへの参照取得】を試みる例）
Private Sub GetWorkbook()
Dim cWb As cGetWorkbook
Dim myPath As String
Dim myBook As Workbook
Set cWb = cM.GetWorkbookClass
With cWb
myPath = .DeskTopPath & "\test.xls" '取得したいブックのフルパス
Set myBook = .GetWorkbook(myPath) '<===★★★ ここ ★★★
If .ErrDescription <> "" Then
'エラーがあった場合
MsgBox .ErrDescription, vbExclamation, "アドインの素"
'"同名ブックが開いています。" (.SameName=True)
'"ファイルが見つかりません。"
'その他のエラーによるメッセージなど
Exit Sub
End If
'Open済の時はActiveにする
If .AlreadyOpend Then
myBook.Activate
End If
'処理（ここでアクティブになったブックに対して実際に必要な処理を行なう。）
MsgBox myBook.Name & "の処理準備完了", vbInformation
'元々開いていなかった場合は閉じる（開いたままで良ければ記述不要、逆に必ず閉じるなら myBook.Colse）
.AutoClose
End With
Set cWb = Nothing
End Sub
'●アクティブセル(セル結合可)に一枚の画像を読み込む
Private Sub LoadPicture1()
Dim cLP As cLoadPicture
Dim FullPath As String
'画像ファイル選択
FullPath = Application.GetOpenFilename("画像ﾌｧｲﾙ(*.jpg),*.jpg")
If FullPath = "False" Then Exit Sub
Set cLP = cM.LoadPictureClass
With cLP
Set .LoadPointCell = ActiveCell '読み込み位置指定（Selectionとすればその範囲に読み込む）
.PictureFullPath = FullPath
If .LoadPicture Then '画像読み込み '<===★★★ ここ ★★★
With .Picture '読み込んだ画像に対する操作例
.Placement = xlMove
.OLEFormat.Object.PrintObject = True
.OnAction = "拡大縮小" 'おまけ
End With
Else
MsgBox "error", vbExclamation
End If
End With
Set cLP = Nothing
End Sub
'●フォルダ指定して、複数枚の画像を連続して読み込む
Private Sub LoadPicture2()
Dim cFs As cFileSearchLight 'ファイルサーチ、このクラスはアドインサンプル.xlaに含まれています。
Dim cLP As cLoadPicture
Dim FolderPath As String
Dim Files As Variant 'フルパスの配列（ファイル名でソート済）
Dim F As Variant
Dim Fnames As Variant 'ファイル名のみの配列
Dim R As Range
Dim i As Long, j As Long
Dim C As Long
Set cFs = New cFileSearchLight
FolderPath = cFs.SelectFolder 'フォルダ選択
If FolderPath = "" Then
Set cFs = Nothing
Exit Sub
End If
'ファイルサーチ
cFs.LookIn = FolderPath '検索場所
cFs.FileName = "*.jpg;*.jpeg" 'ファイルの種類
If cFs.Execute(msoSortByNumber, msoSortOrderAscending) = 0 Then 'ファイル検索
Set cFs = Nothing
Exit Sub
End If
Files = cFs.FoundFiles 'フルパス（画像を読み込む為のフルパス）
Fnames = cFs.Fnames 'ファイル名のみ（画像にファイル名も表示する為）
Application.ScreenUpdating = False
Set R = Range("B2") '先頭セル
Set cLP = cM.LoadPictureClass
cLP.Compress = True '圧縮指定
cLP.CompressPercent = 70
For Each F In Files
i = (C \ 5) * 2 '*2は2行毎（1行置き）の意
j = C Mod 5 '上とここの5は5列で折り返しの意
Set cLP.LoadPointCell = R.Offset(i, j) '★読み込み位置
cLP.PictureFullPath = F '★フルパス
cLP.LoadPicture '★画像読み込み
R.Offset(i + 1, j).Value = Fnames(C + 1) 'ファイル名表示（C+1は戻り値の配列が1からなので）
cLP.Picture.OnAction = "図の拡大縮小" 'おまけ
C = C + 1
Next
ActiveCell.Activate '圧縮した場合、図が選択状態のままになるので
Application.ScreenUpdating = True
Set cFs = Nothing
Set cLP = Nothing
End Sub
'●図の拡大縮小
Private Sub 図の拡大縮小()
Dim cLP As cLoadPicture
Dim Pic As Shape
Dim W As Single, H As Single
Set Pic = ActiveSheet.Shapes(Application.Caller) 'クリックした図
W = Pic.Width: H = Pic.Height
Set cLP = cM.LoadPictureClass
With cLP
Set .Picture = Pic
Set .LoadPointCell = Pic.TopLeftCell.MergeArea
.ResetOriginalSize '★一旦元のサイズに戻す
Pic.ZOrder msoBringToFront
If Pic.Width = W And Pic.Height = H Then
.FitInTheCell '★セルの大きさに合わせる
End If
End With
Set cLP = Nothing
End Sub
'●選択してある図をその大きさに圧縮
Private Sub CompressPicture()
Dim cLP As cLoadPicture
Dim OnActionBak As String
Set cLP = cM.LoadPictureClass
With cLP
Set .Picture = Selection.ShapeRange(1)
OnActionBak = .Picture.OnAction
.CompressPicture(.Picture).OnAction = OnActionBak '<===★★★ ここ ★★★
End With
Set cLP = Nothing
End Sub
'●シート上のすべての画像を一括圧縮
Private Sub CompressAll()
Dim cLP As cLoadPicture
Dim Shp As Shape
Dim OnActionBak As String 'OnActionのバックアップ用
Dim Snames() As String
Dim C As Long
Dim i As Long
'一旦名前を配列に取得しておく
For Each Shp In ActiveSheet.Shapes
If Shp.Type = msoPicture Then
C = C + 1
ReDim Preserve Snames(1 To C)
Snames(C) = Shp.Name
End If
Next
Application.ScreenUpdating = False
Set cLP = cM.LoadPictureClass
For i = 1 To C
Set Shp = ActiveCell.Worksheet.Shapes(Snames(i))
OnActionBak = Shp.OnAction
'===★★★ ここ ★★★
Set Shp = cLP.CompressPicture(Shp, 70) '圧縮（％数値指定しなければ現在の大きさに圧縮される）
Shp.OnAction = OnActionBak
Next
ActiveCell.Activate
Application.ScreenUpdating = True
Set cLP = Nothing
End Sub
'●手作業で任意に移動した図をセル内にきっちり収める（シート上一括）
Private Sub FitInTheCell()
Dim cLP As cLoadPicture
Dim Shp As Shape
Set cLP = cM.LoadPictureClass
For Each Shp In ActiveSheet.Shapes
If Shp.Type = msoPicture Then
Set cLP.LoadPointCell = Shp.TopLeftCell.MergeArea
Set cLP.Picture = Shp
cLP.Margin = 2
cLP.FitInTheCell '<===★★★ ここ ★★★
End If
Next
Set cLP = Nothing
End Sub
'●配列同士の比較（二次元も可）
Private Sub MatchArray()
Dim cMA As cMatchArray
Dim AA As Variant
Dim BB As Variant
Dim i As Long
Set cMA = cM.MatchArrayClass
cMA.TextMode = False
AA = Array("A", "c", "f", "b", "e", "d")
BB = Array("c", "d", "ａ", "b", "f", "E")
cMA.MatchArray AA, BB '比較処理 '<===★★★ ここ ★★★
With cMA
'結果、不一致や一致が在ったか無かったか
Debug.Print "ExistUnMatchA", .ExistUnMatchA
Debug.Print "ExistUnMatchB", .ExistUnMatchB
Debug.Print "ExistMatchA", .ExistMatchA
Debug.Print "ExistMatchB", .ExistMatchB
Debug.Print
End With
With cMA
If .ExistUnMatchA Then '配列Aの不一致
Debug.Print "UnMatchA"
For i = 1 To UBound(.ndxA)
Debug.Print .ndxA(i); .UnMatchA(i), 'インデックス, 値（以下同様）
Next: Debug.Print
End If
If .ExistUnMatchB Then '配列Bの不一致
Debug.Print "UnMatchB"
For i = 1 To UBound(.ndxB)
Debug.Print .ndxB(i); .UnMatchB(i),
Next: Debug.Print
End If
Debug.Print
If .ExistMatchA Then '配列Aの一致
Debug.Print "MatchA"
For i = 1 To UBound(.ndxWA)
Debug.Print .ndxWA(i); .MatchA(i),
Next: Debug.Print
End If
If .ExistMatchB Then '配列Bの一致
Debug.Print "MatchB"
For i = 1 To UBound(.ndxWB)
Debug.Print .ndxWB(i); .MatchB(i),
Next: Debug.Print
End If
Debug.Print
End With
Set cMA = Nothing
End Sub
'●メール送信クラス使用例
Private Sub SendMessage()
Dim cMail As cMessage
Set cMail = cM.MessageClass
With cMail
.Server = "SendMailServerAddress" 'ex. smtp.isp.or.jp
.ServerPort = 25
.UseSSL = False
.SendAuthenticate = 認証不要
.Timeout = 60
.SendFrom = "差出人表示名"
.SendTo = "宛先表示名" '複数は ; で繋ぐ、CC, BCCも同様
.Subject = "件名をここに書く"
.TextBody = "メール本文をここに書く"
If .Send Then
MsgBox "OK"
Else
MsgBox .ErrMsg, vbExclamation
End If
End With
Set cMail = Nothing
End Sub
'●メール送信クラス使用例２（.Setup(送信サーバー情報の設定)使用）
Private Sub SetupMessage()
Dim cMail As cMessage
Set cMail = cM.MessageClass
cMail.Setup "プロジェクト名" '送信サーバー情報の設定（保存名は「Work」「Private」「N氏宛」など任意）
Set cMail = Nothing
End Sub
Private Sub SendMessage2()
Dim cMail As cMessage
Set cMail = cM.MessageClass
With cMail
.LoadConfig "プロジェクト名" 'Setupが完了していればサーバー情報はこの行だけでレジストリから取得できる
.SendTo = "宛先表示名"
.Subject = "ここに件名"
.TextBody = "ここに送信テキスト本文"
If .Send Then
MsgBox "OK", vbInformation
Else
MsgBox .ErrMsg, vbExclamation
End If
End With
Set cMail = Nothing
End Sub
'●プログレスバー（フォーム）の基本コード
Private Sub ProgressBar()
Const myMax As Long = 1000
Dim cBar As cProgressForm
Dim i As Long, j As Long
'初期設定
Set cBar = cM.ProgressClass
With cBar
.Caption = "しばらくお待ちください．．．"
.Min = 0
.Max = myMax
End With
'処理ループ
cBar.Start
For i = 1 To myMax
If cBar.Cancel Then
If MsgBox("中止しますか？", vbYesNo + vbQuestion) = vbYes Then
Exit For
End If
End If
'実際の処理
For j = 1 To 10000000
Next
cBar.Value = i
Next
If cBar.Cancel Then
MsgBox "中止しました。", vbExclamation
Else
MsgBox "完了しました。", vbInformation
End If
Set cBar = Nothing
End Sub
'●プログレスライトの基本コード
Private Sub ProgressLight()
Const myMax As Long = 100
Dim cBar As cProgressLight
Dim i As Long, j As Long
'初期設定
Set cBar = cM.ProgressLightClass
With cBar
.Style = plBarAndPercent 'plBarAndPercentAndRestTime, plBarAndRestTime, plBarOnly
.Min = 0
.Max = myMax
End With
'処理ループ
cBar.Start
For i = 1 To myMax
'実際の処理
For j = 1 To 10000000
Next
cBar.Value = i
Next
MsgBox "完了しました。", vbInformation
Set cBar = Nothing
End Sub
'●正規表現クラス、一般例
Private Sub RegExp()
Dim myRegExp As cRegExp
Dim myStr As String
Dim i As Long
myStr = "1aa2a34aaa5"
Set myRegExp = cM.RegExpClass
With myRegExp
.Pattern = "\d\D\d" '「数字,数字以外,数字」が各１文字のパターン
.Globall = False
.IgnoreCase = False
If .Execute(myStr) Then
Debug.Print .Value '"2a3"
Debug.Print .FirstIndex '3 （オフセット）
Debug.Print .Length '3
Debug.Print .LeftValue '"1aa"
Debug.Print .RightValue '"4aaa5"
End If
End With
Set myRegExp = Nothing
End Sub
'●正規表現クラス、全て検索
Private Sub RegExpAll()
Dim myRegExp As cRegExp
Dim myStr As String
Dim i As Long
myStr = "1aa2a34aaa5"
Set myRegExp = cM.RegExpClass
With myRegExp
.Pattern = "\d+" '数字１文字以上の連続
.Globall = True '全て
.IgnoreCase = False
.Execute myStr '検索
For i = 0 To .MatchesCount - 1
Debug.Print .Value(i) '1, 2, 34, 5
Next
End With
Set myRegExp = Nothing
End Sub
'●正規表現クラス、すべて置換え
Private Sub RegExpReplace()
Dim myRegExp As cRegExp
Dim myStr As String
myStr = "1aa2a34aaa5"
Set myRegExp = cM.RegExpClass
With myRegExp
.Pattern = "\d+" '数字１文字以上の連続
.Globall = True '全て
.IgnoreCase = False
myStr = .Replace(myStr, "0") '置換え
End With
Debug.Print myStr '0aa0a0aaa0
Set myRegExp = Nothing
End Sub
'●ソート関数使用例（通常使用、安定ソート、２次元・複数キー指定も可。）
Private Sub SortTest1()
Dim VV As Variant
Dim V As Variant
VV = Array(3, 7, 2, 9, 5, 5, 1, 1, 7, 2, 9)
'VV = Array("Aab", "aaa", "aa", "a", "aaＢ", "aaB", "aac", "Aab", "abb", "abc", "a")
VV = Sort(VV) '★最低限はこれだけでOK（Sort関数部はフリーウエアです。）
For Each V In VV
Debug.Print V; " ";
Next
Debug.Print
End Sub
'●ソートクラスを使った簡易ソート関数（安定・非安定（高速）選択式）
Public Function SortExp(Ary As Variant, Optional SortOrder As XlSortOrder = xlAscending _
, Optional MatchCase As Boolean = True, Optional MatchByte As Boolean = True _
, Optional TextMode As Boolean = False, Optional Constancy As Boolean = True) As Variant
'※非安定指定（Constancy=False=高速）は、１次元または２次元１列の配列のみ可
Dim cSort As cMsSort
Set cSort = cM.SortClass
With cSort
.Constancy = Constancy 'True:安定（低速）、False:非安定（高速）
.SortOrder = SortOrder
.TextMode = TextMode
.MatchCase = MatchCase
.MatchByte = MatchByte
SortExp = .Sort(Ary)
End With
Set cSort = Nothing
End Function
'●簡易ソート関数、並べ替え順指定の確認
Private Sub 並べ替え順指定の確認()
Dim VV As Variant
Dim V As Variant
Dim i As Long
VV = Array("ｲ", "ｱ", "ｂ", "ａ", "Ｄ", "Ｃ", "２", "１", "高橋", "鈴木", "佐藤", "イ", "ア", "い", "あ", "b", "a", "_", "\", "D", "C", "2", "1")
For i = 1 To 4
Select Case i
Case 1
VV = SortExp(VV) '既定値
Case 2
VV = SortExp(VV, MatchCase:=False) '大小文字区別なし
Case 3
VV = SortExp(VV, MatchCase:=False, MatchByte:=False) '大小全角半角区別なし
Case 4
VV = SortExp(VV, , , TextMode:=True) 'Textモード
End Select
For Each V In VV
Debug.Print V; " ";
Next
Debug.Print
Next
End Sub
'●クラスを直接使ったソートの基本形（２次元も可）
Private Sub BasicSort()
Dim cSort As cMsSort
Dim VV As Variant
Dim V As Variant
Set cSort = cM.SortClass
VV = Array(3, 7, 2, 9, 5, 5, 1, 1, 7, 2, 9)
'VV = Array("Aab", "aaa", "aa", "a", "aaＢ", "aaB", "aac", "Aab", "abb", "abc", "a")
With cSort
.SortOrder = xlAscending '昇順降順
.MatchCase = True '大文字小文字
.MatchByte = True '全角半角
.TextMode = False 'Textモード
VV = .Sort(VV) '★並べ替えた値をクラスからそのまま取得
End With
For Each V In VV
Debug.Print V; " ";
Next
Debug.Print
End Sub
'●クラスを使った複数キー指定ソートの基本形
Private Sub SomeKeysSort()
Dim cSort As cMsSort
Dim V1 As Variant
Dim V2 As Variant
Dim Ndx As Variant
Dim i As Long, j As Long
Dim L1 As Long, U1 As Long, L2 As Long, U2 As Long
Set cSort = cM.SortClass
V1 = ActiveCell.CurrentRegion.Value '元データ（この例では３列以上が必要）
'並べ替えインデックスを繰り返し並べ替え、
With cSort
.Constancy = True '安定ソート指定
.Column = 3: Ndx = .SortIdx(V1)
.Column = 2: Ndx = .SortIdx(V1, Ndx)
.Column = 1: Ndx = .SortIdx(V1, Ndx)
End With
L1 = LBound(V1, 1): U1 = UBound(V1, 1)
L2 = LBound(V1, 2): U2 = UBound(V1, 2)
ReDim V2(L1 To U1, L2 To U2)
'最後に実値を入れる
For i = L1 To U1
For j = L2 To U2
V2(i, j) = V1(Ndx(i), j)
Next
Next
ActiveCell.CurrentRegion.Value = V2 '※上書き注意
End Sub
'●ソート用サンプルデータ（セルデータ）作成
Private Sub CreateSampleData()
Dim cTd As cTestData
Dim V As Variant
Dim i As Long
Dim R As Range
Static Shu As Long
Static N As Long
Static Rw As Long
Dim Res As String
Dim N2 As Long
Dim wByte As Boolean
Dim LCasee As Boolean
If Shu = 0 Then Shu = 1
If N = 0 Then N = 3
If Rw = 0 Then Rw = 100
'種類
Res = InputBox("種類の番号を入力して下さい。" & vbCrLf & _
"１．数字 ２．英数字 ３．全角 ４．ランダム", "種類選択", CStr(Shu))
If Res = "" Then Exit Sub
Shu = CLng(Res)
If Shu < 1 Then Shu = 1
If Shu > 4 Then Shu = 4
'文字数
Res = InputBox("文字数を入力して下さい。", "文字数入力", CStr(N))
If Res = "" Then Exit Sub
N = CLng(Res)
If N <= 0 Then N = 3
'行数
Res = InputBox("行数を入力して下さい。", "行数入力", CStr(Rw))
If Res = "" Then Exit Sub
Rw = CLng(Res)
'データ作成
Randomize
Set cTd = cM.TestDataClass
ReDim V(1 To Rw, 1 To 1)
For i = 1 To Rw
Select Case Shu
Case 1
V(i, 1) = cTd.数字(N)
Case 2
V(i, 1) = cTd.英数字(N)
Case 3
V(i, 1) = cTd.全角(N)
Case 4
N2 = Int(Rnd() * (N * 1.5 - 1 + 1) + 1)
If Rnd() < 0.5 Then
wByte = False
Else
wByte = True
End If
If Rnd() < 0.5 Then
LCasee = False
Else
LCasee = True
End If
Select Case Rnd()
Case Is < 0.17
V(i, 1) = cTd.カタカナ(N2, wByte)
Case Is < 0.33
V(i, 1) = cTd.ひらがな(N2)
Case Is < 0.5
V(i, 1) = cTd.英字(N2, LCasee, wByte)
Case Is < 0.67
V(i, 1) = cTd.英数字(N2, wByte)
Case Is < 0.83
V(i, 1) = cTd.数字(N2, wByte)
Case Else
V(i, 1) = cTd.全角(N2)
End Select
End Select
Next
'書き込み
Application.ScreenUpdating = False
Set R = ActiveCell
If IsEmpty(R.Value) And (R.End(xlDown).Row = Rows.Count) Then '列が空ならそこへ
Else
Set R = Workbooks.Add.Worksheets(1).Range("A1") 'そうでなければ新規ブック自動作成
End If
R.Resize(Rw).Value = V
Application.ScreenUpdating = True
Set cTd = Nothing
End Sub
'●含まれている番号（数値）による並べ替え関数（主にファイル名のソートに使用、一次元配列限定）
Public Function NumSort(Ary As Variant) As Variant
Dim cNumSort As cNumSort
Set cNumSort = cM.NumSortClass
With cNumSort
.SortOrder = nsAscending
.MatchCase = False
.MatchByte = False
NumSort = .Sort(Ary)
End With
Set cNumSort = Nothing
End Function
'●番号（数値）による並べ替え関数の使用例
Private Sub NumSortCallSample()
Dim Fnames As Variant
Dim nA As Variant
Fnames = Array("B(10).jpg", "B(20).jpg", "B(1).jpg", "B(9).jpg", "a(10).jpg", "a(2).jpg", "a(1).jpg", "a(9).jpg")
Fnames = NumSort(Fnames)
If VarType(Fnames) = vbBoolean Then
Debug.Print "Error"
Else
For Each nA In Fnames
Debug.Print nA
Next
End If
Debug.Print
End Sub
'●ユーザー定義リストによる並べ替え関数
Public Function UserSort(Ary As Variant, UserList As Variant, _
Optional Colm As Variant) As Variant
'※エラー時はFalse
Dim cSort As cMsSort
Dim Dic As Object 'Dictionary
Dim Ndx As Variant
Dim Ary2() As Variant
Dim L As Long
Dim U As Long
Dim L2 As Long
Dim U2 As Long
Dim i As Long
Dim j As Long
Dim Dimen As Long '引数配列の次元
Set cSort = cM.SortClass
'次元確認 ＊＊＊＊＊
Dimen = cSort.Dimension(Ary)
If Dimen <= 0 Or Dimen >= 3 Then
UserSort = False
Set cSort = Nothing
Exit Function
End If
If IsMissing(Colm) And Dimen = 2 Then
Colm = LBound(Ary, 2)
End If
'DictionaryにUserListを登録する
Set Dic = CreateObject("Scripting.Dictionary")
For i = LBound(UserList) To UBound(UserList)
Dic(UserList(i)) = i
Next
'Dictionaryに登録したUserListから並べ替えの元ネタインデックスを作る
L = LBound(Ary)
U = UBound(Ary)
ReDim Ndx(L To U)
If Dimen = 1 Then
'一次元
For i = L To U
If Dic.Exists(Ary(i)) Then
Ndx(i) = Dic(Ary(i))
Else
Ndx(i) = 2000000000# '対象外は最後尾
End If
Next
Else
'二次元
For i = L To U
If Dic.Exists(Ary(i, Colm)) Then
Ndx(i) = Dic(Ary(i, Colm))
Else
Ndx(i) = 2000000000# '対象外は最後尾
End If
Next
End If
Set Dic = Nothing
'元ネタインデックスの並べ替えインデックスを得る
With cSort
.SortOrder = xlAscending
.Constancy = True
.Column = Colm
Ndx = .SortIdx(Ndx)
End With
Set cSort = Nothing
'インデックスを使って並べ替える
If Dimen = 1 Then
'一次元
ReDim Ary2(L To U)
For i = L To U
Ary2(i) = Ary(Ndx(i))
Next
Else
'二次元
L2 = LBound(Ary, 2)
U2 = UBound(Ary, 2)
ReDim Ary2(L To U, L2 To U2)
For i = L To U
For j = L2 To U2
Ary2(i, j) = Ary(Ndx(i), j)
Next
Next
End If
UserSort = Ary2
End Function
'●ユーザー定義リストによる並べ替え関数の使用例
Private Sub UserSortCallSample()
Dim UserList As Variant
Dim Ary As Variant
Dim V As Variant
UserList = Array("S", "M", "L", "LL")
Ary = Array("M", "LL", "M", "SS", "S", "3L", "L", "S")
Ary = UserSort(Ary, UserList)
For Each V In Ary
Debug.Print V; " ";
Next
Debug.Print
End Sub
'●Splitクラス使用例（通常のSplit関数との主な違い："で囲まれた文字列を分割しない事）
Private Sub MsSplit()
Dim cSp As cMsSplit
Dim A As Variant
Dim S As String
Set cSp = cM.SplitClass
S = "ab," & Chr$(34) & "cd,ef" & Chr$(34) & ",ghi"
A = cSp.Split(S)
Debug.Print S 'ab,"cd,ef",ghi
Debug.Print "↓"
Debug.Print A(1) 'ab
Debug.Print A(2) '"cd,ef"
Debug.Print A(3) 'ghi
Debug.Print
End Sub
'●Split2関数（2を付けたのは、通常のSplit関数（＝VBA.Split）と区別する為）
Public Function Split2(Expression As String, _
Optional Delimiter As String = " ", Optional ConsecutiveDelimiter As Boolean = False, _
Optional TextQualifier As String = """", _
Optional Compare As VbCompareMethod = vbBinaryCompare) As Variant
'Delimiter:区切り文字
'ConsecutiveDelimiter:連続した区切り文字を１文字として扱うか否か
'TextQualifier:文字列の囲み文字、初期値は「"」
'Compare:区切り文字の大文字・小文字・全角・半角の区別の仕方（区別しない時はvbTextCompare）
Dim cSp As cMsSplit
Set cSp = cM.SplitClass
With cSp
.BaseNumber = 0
.Delimiter = Delimiter
.ConsecutiveDelimiter = ConsecutiveDelimiter
.TextQualifier = TextQualifier
.Compare = Compare
Split2 = .Split(Expression)
End With
Set cSp = Nothing
End Function
'●Split2関数使用例（スプリットクラスと通常のSplit関数の違い確認用）
Private Sub Split2CallSample()
Dim SS As String
Dim VV As Variant, V As Variant
SS = "12,""3,45"",67,,""8,9"""
VV = Split2(SS, ",")
' VV = Split2(SS, ",", ConsecutiveDelimiter:=True)
' VV = VBA.Split(SS, ",")
Debug.Print SS
For Each V In VV
Debug.Print "*"; V; "*"
Next
Debug.Print
End Sub
'●iniファイル読み書き（クラスを直接使用）
Private Sub iniTest()
Dim myPath As String
Dim cIni As cMsIni
Set cIni = cM.IniClass
myPath = ThisWorkbook.Path & "\Test.ini"
With cIni
.FilePath = myPath
.Section = "[TestSection]"
.PutData Key:="Key1=", Val:="1" '書き込むデータは文字列
.PutData Key:="Key2=", Val:="TRUE"
Debug.Print "*"; Val(.GetData(Key:="Key1=")); "*" '読み込んだ後は必要に応じて、型変換
Debug.Print "*"; CBool(.GetData(Key:="Key2=")); "*"
Debug.Print "*"; .Exist(Key:="Key3="); "*"
Debug.Print "*"; .GetData(Key:="Key3="); "*"
Debug.Print
End With
Set cIni = Nothing
End Sub
'●iniファイル関数（※コール時、"[Section]", "Key=" のように両端の[ ]と最後の=を忘れない事）
Public Sub PutData(FilePath As String, Section As String, Key As String, ByVal Value As String)
'◆Data書き込み
Dim cIni As cMsIni
Set cIni = cM.IniClass
With cIni
.FilePath = FilePath
.Section = Section
Value = .EncCrLf(Value) '改行が含まれていたら変換しておく
.PutData Key, Value
End With
Set cIni = Nothing
End Sub
Public Function GetData(FilePath As String, Section As String, Key As String) As String
'◆Data読み取り
Dim cIni As cMsIni
Dim Value As String
Set cIni = cM.IniClass
With cIni
.FilePath = FilePath
.Section = Section
Value = .GetData(Key)
Value = .DecCrLf(Value) '改行を変換した文字があったら戻しておく
End With
GetData = Value
Set cIni = Nothing
End Function
Public Sub PutList(FilePath As String, Section As String, _
ListData As Variant, Optional Delimiter As String = " ")
'◆List書き込み（ListData：一次元または二次元配列、Delemiter：二次元の時の列連結文字）
Dim cIni As cMsIni
Set cIni = cM.IniClass
With cIni
.FilePath = FilePath
.Section = Section
.PutList ListData, Delimiter
End With
Set cIni = Nothing
End Sub
Public Function GetList(FilePath As String, Section As String, _
Optional Column As Integer = 0, Optional Delimiter As String = " ") As Variant
'◆List読み取り（指定したセクションに記述されているリストを文字配列で返す。）
'Column指定ありなら、各行をDelimiterで区切り2次元配列(行, 列)に入れて返す。
'iniファイルが無い、セクションが見つからない、リストが１個もない時は、Falseを返す。
Dim cIni As cMsIni
Set cIni = cM.IniClass
With cIni
.FilePath = FilePath
.Section = Section
GetList = .GetList(Column, Delimiter)
End With
Set cIni = Nothing
End Function
Public Sub DelData(FilePath As String, Section As String, _
Optional Key As String = "", Optional DeleteSection As Boolean = False)
'◆KeyまたはSectionの削除（DeleteSection:=True＝＝＞セクション丸ごと削除）
Dim cIni As cMsIni
Set cIni = cM.IniClass
With cIni
.FilePath = FilePath
.Section = Section
.DelData Key, DeleteSection
End With
Set cIni = Nothing
End Sub
'●iniファイル関数使用例
Private Sub iniCallTest1()
'◆単一データ
Dim myPath As String
myPath = DeskTopPath & "\test.ini"
PutData myPath, "[mySection]", "key1=", "abc"
PutData myPath, "[mySection]", "key2=", "xyz"
PutData myPath, "[mySection2]", "key1=", "321"
Debug.Print GetData(myPath, "[mySection]", "key1=")
End Sub
Private Sub iniCallTest2()
'◆リストデータ
Dim myPath As String
Dim VV As Variant, V As Variant
Dim i As Long, j As Long
myPath = DeskTopPath & "\test.ini"
PutList myPath, "[ListSection1]", Array("11,12,13", "21,22,23", "31,32,33")
VV = GetList(myPath, "[ListSection1]")
For Each V In VV
Debug.Print V
Next
Debug.Print
VV = GetList(myPath, "[ListSection1]", Column:=2, Delimiter:=",")
For i = LBound(VV) To UBound(VV)
For j = LBound(VV, 2) To UBound(VV, 2)
Debug.Print VV(i, j),
Next: Debug.Print
Next
Debug.Print
End Sub
Private Sub iniCallTest3()
'◆データ削除（Key削除）
Dim myPath As String
myPath = DeskTopPath & "\test.ini"
DelData myPath, "[mySection]", "key2="
End Sub
Private Sub iniCallTest4()
'◆セクション削除
Dim myPath As String
myPath = DeskTopPath & "\test.ini"
DelData myPath, "[mySection]", , DeleteSection:=True
End Sub
'●行名・列名でテーブル内の該当位置を検索し、値の記入などをする例
Private Sub SetTableData()
Dim rngTbl As Range
Dim cTbl As cTable
Dim Res As VbMsgBoxResult
Dim R As Range
CreateTestData '新規ブックにサンプルデータ作成
Res = MsgBox("続けますか", vbYesNo + vbQuestion, "テーブルクラスサンプル")
If Res = vbNo Then
ActiveWorkbook.Saved = True
Exit Sub
End If
'テーブル
Set rngTbl = ActiveCell.Worksheet.Range("A1").CurrentRegion
'TableClassのインスタンス取得＆プロパティ設定
Set cTbl = cM.TableClass
With cTbl
.KeyTypeRow = ktString '行の型を文字列に設定
.KeyTypeCol = ktDate '列の型を日付に設定
Set .Table = rngTbl 'テーブル範囲を設定
End With
'★★★★★ テーブルの該当セル検索 ★★★★★
Set R = cTbl.Item("D", Date + 2) '明後日の"D"の位置
'該当セルがあれば
If Not R Is Nothing Then
R.Value = "ここ"
R.Interior.Color = vbYellow
End If
'サンプルブックを閉じる時に一々「保存しますか」と聞かれないように
ActiveWorkbook.Saved = True
Set cTbl = Nothing
End Sub
'新規ブックにテーブルクラス用のサンプルデータ作成
Private Sub CreateTestData()
Dim rngTbl As Range
Dim V As Variant
Dim i As Long
Dim N As Long
'テーブル
Set rngTbl = Workbooks.Add.Worksheets(1).Range("A1").Resize(11, 8)
'行名（A〜J）
N = 10
ReDim V(1 To N, 1 To 1)
V = Application.WorksheetFunction.Transpose(Split("A B C D E F G H I J"))
Intersect(rngTbl.Columns(1).Offset(1), rngTbl).Value = V
'列名（今日から7日）
N = 7
ReDim V(1 To N)
For i = 1 To N
V(i) = Date + i - 1
Next
With Intersect(rngTbl.Rows(1).Offset(, 1), rngTbl)
.NumberFormatLocal = "m月d日"
.Cells.Value = V
End With
rngTbl.Worksheet.UsedRange.EntireColumn.AutoFit
End Sub
'●テキストファイル全体を単純に読み込み
Private Sub ReadAllText()
Dim cTxt As cTextFile
Set cTxt = cM.TextFileClass
With cTxt
.ReadPath = .DeskTopPath & "\Sample.txt" '読み込みファイルのフルパス
If .ReadAll Then '★読み込み
Debug.Print .AllText '成功したら表示
Else
Debug.Print .ErrorDescription '失敗したらエラー表示
End If
End With
Set cTxt = Nothing
End Sub
'●テキストファイルの各行を配列に読み込み
Private Sub ReadToArray()
Dim cTxt As cTextFile
Dim VV As Variant
Dim i As Long
Set cTxt = cM.TextFileClass
With cTxt
.ReadPath = .DeskTopPath & "\Sample.txt"
If .ErrorDescription <> "" Then
Debug.Print .ErrorDescription
Else
VV = .ArrayText '★配列として取得
For i = 0 To UBound(VV)
Debug.Print "*"; VV(i); "*"
Next
End If
End With
Set cTxt = Nothing
End Sub
'●テキストファイルへ単純な書き込み
Private Sub SimplyWrite()
Dim cTxt As cTextFile
Const Txt As String = "テスト３"
Set cTxt = cM.TextFileClass
With cTxt
.WritePath = .DeskTopPath & "\Test.txt" '書き込みファイルのフルパス
If .Write1(Txt) Then '★末尾に改行付きで書き込み
Debug.Print "ok"
Else
Debug.Print .ErrorDescription
End If
End With
Set cTxt = Nothing
End Sub
'●テキストファイルへの色々な書き込み
Private Sub WriteEtc()
Dim cTxt As cTextFile
Set cTxt = cM.TextFileClass
With cTxt
.SaveChanges = False '既存ファイルへの上書き禁止（但し追加は除く）
' .Append = True '追加書き込みの指定
' .Unicode = True 'Unicodeの指定
'(シフトJISファイルにUnicodeで追加などというような無茶な指定はしないように^^;)
'(もし、Appendモード時に自動でUnicode判別したければ、一旦ダミーでそのファイルを読み込めば良い。)
.WritePath = .DeskTopPath & "\Test2.txt"
If .ErrorDescription <> "" Then
Debug.Print .ErrorDescription
Else
If .Write0("テスト４") Then '★末尾の改行無しで書き込み
Debug.Print "ok"
Else
Debug.Print .ErrorDescription
End If
End If
End With
Set cTxt = Nothing
End Sub
'●テキストファイルの最初と最後の行を別ファイルに出力
Private Sub ReadAndWrite()
Dim cTxt As cTextFile
Dim VV As Variant
Set cTxt = cM.TextFileClass
With cTxt
.ReadPath = .DeskTopPath & "\Sample.txt" '読み込みファイルのフルパス
VV = .ArrayText '配列に取り込む
.WritePath = .ReadPath & "_2.txt" '書き込みファイルのフルパス
.Write1 CStr(VV(LBound(VV))) '最初の行を書き込み
.Append = True '追加書き込みモード指定
.Write1 CStr(VV(UBound(VV))) '最後の行を書き込み
End With
Set cTxt = Nothing
End Sub
'●テキストファイル中の文字列置換え（正規表現クラスを使用）
Private Sub ReplaceString()
Dim cTxt As cTextFile
Dim cReg As cRegExp
Dim Txt As String
Dim Bf As String '置換え前の文字列（パターン）
Dim Af As String '置換え後の文字列
Dim C As Long
Dim Ans As Integer
Set cTxt = cM.TextFileClass
Set cReg = cM.RegExpClass
' Bf = "([A-Za-z])\1{2}" '例１．同じ半角英字の３文字連続した部分の指定
' Bf = "([A-Za-z0-9]+)(\s*)-(\s*)([A-Za-z0-9]+)" '例２．英数字 - 英数字
' Af = "$4$2-$3$1" '例２．上記 - の前後入替
Bf = "ＡＢ" '半角記号(正規表現で特別な意味を持つ)以外の文字のみを指定すれば、それとの単純な一致となる
Af = "xyz"
With cTxt
.ReadPath = .DeskTopPath & "\Sample.txt" '対象テキストファイルフルパス
Txt = .AllText '★テキストファイルから読み込み
With cReg
.Pattern = Bf
.Globall = True '全検索、最初の一件のみならFalse
If .Execute(Txt) Then '★検索
C = .MatchesCount
Ans = MsgBox(C & "件マッチしました。置き換えますか。", vbQuestion + vbOKCancel + vbDefaultButton2)
If Ans = vbOK Then
Txt = .Replace(Txt, Af) '★メモリー上で置換え
Else
C = 0
End If
End If
End With
If C >= 1 Then
'書き込み先フルパス＝元フルパス&_Repl.txt。元ファイルへ上書きなら & 以降は不要
.WritePath = .ReadPath & "_Repl.txt"
.Write0 Txt '★テキストファイルへ書き戻し
End If
End With
Set cTxt = Nothing
Set cReg = Nothing
End Sub
'●TextBoxとSpinButtonの連動
Private Sub TextSpins()
Dim cTs As cTxtSpns
Set cTs = cM.TxtSpnsClass
Load TxtSpnsSample 'UserFormのロード
With TxtSpnsSample
cTs.Add .TextBox1, .SpinButton1 '★連動させるTextBoxとSpinButtonを必要なだけ.Addする
cTs.Add .TextBox2, .SpinButton2
.Show 'UserFormの表示
End With
End Sub
'===== UserFormモジュール ===== 'Option Explicit Private cSet As cFormSetting'●ユーザーフォーム、全コントロール値の保存と読み込み
Private Sub cmdSave_Click()
cSet.SaveAll
End Sub
Private Sub cmdLoad_Click()
cSet.LoadAll
End Sub
'●ユーザーフォーム、特定のコントロール値の保存と読み込み
Private Sub cmdSaveOne_Click()
cSet.SaveOne Me.ComboBox1
End Sub
Private Sub cmdLoadOne_Click()
cSet.LoadOne Me.ComboBox1
End Sub
'ユーザーフォーム上の値を変化させるための適当なコード
Private Sub SpinButton1_Change()
Me.Label1.Caption = Me.SpinButton1.Value
End Sub
Private Sub UserForm_Click()
Me.ComboBox1.Clear
End Sub
'ユーザーフォームの初期化でクラスインスタンス生成と初期設定
Private Sub UserForm_Initialize()
Me.ComboBox1.List = Array(1, 2, 3, 4, 5)
Me.ListBox1.List = Array("a", "b", "c", "d", "e")
Set cSet = cM.FormSettingClass '★クラスインスタンス生成
With cSet
' .iniPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\test.ini"
'iniファイルのパスは上記のように任意に指定もできますが、通常は.Bookプロパティでユーザーアドインブックを
'指定して同じフォルダ内に自動で付けた名前にしておくのが良いです。
Set .Book = ThisWorkbook '★設定
Set .Form = Me '★設定
.LoadAll '★保存値の読み込み
End With
SpinButton1_Change
End Sub
Private Sub UserForm_Terminate()
' cSet.SaveAll 'Terminate時の実行では一部保存できないコントロールの値があるので、Saveボタンで明示的に保存することを推奨します。
Set cSet = Nothing
End Sub
'===== UserFormモジュールここまで =====