ラベル Programming ExcelVBA の投稿を表示しています。 すべての投稿を表示
ラベル Programming ExcelVBA の投稿を表示しています。 すべての投稿を表示

2023年4月30日日曜日

[VBA]Excelのシートを並べ替え

[はじめに]
Excelでシートを昇順に並べ替える機会があったので、
備忘録としてサンプルソースを掲載します。
サンプルは昇順ソートですが、引数を変更すると降順にも対応できるようにしています。

[ソース]
Option Explicit

'''<summary>
'''ソートの向き
'''</summary>
'''<remarks></remarks>
Public Enum SortType
    '昇順
    Asc = 1
    '降順
    Desc = -1
End Enum

'''<summary>
'''シートをソートする。
'''</summary>
'''<remarks></remarks>
Public Sub SortSheet()

    Dim sht As Worksheet
    Dim i As Integer
    Dim shtName As Variant
    Dim shtNameList() As String
    
    'シート名を配列で取得する。
    For Each sht In ThisWorkbook.Worksheets
        ReDim Preserve shtNameList(i)
        shtNameList(i) = sht.Name
        i = i + 1
    Next

    '配列でソートする。
    SortByQuick shtNameList, SortType.Asc, 0, UBound(shtNameList)

    '配列の順番でシートをソートする。
    Dim strWork As String
    strWork = shtNameList(UBound(shtNameList))
    
    For i = 0 To UBound(shtNameList)
        ThisWorkbook.Sheets(shtNameList(i)).Move after:=ThisWorkbook.Sheets(strWork)
        strWork = shtNameList(i)
    Next

End Sub

'''<summary>
'''Stringの配列を名称の昇順にソートする。
'''</summary>
'''<param name="argAry">ソート対象の配列</param>
'''<param name="sort">ソートの向き　※省略時：Asc（昇順）</param>
'''<param name="lngMin">対象範囲の最小インデックス ※省略時：argAryの最小インデックス</param>
'''<param name="lngMax">対象範囲の最大インデックス ※省略時：argAryの最大インデックス</param>
'''<remarks></remarks>
Private Sub SortByQuick( _
        ByRef argAry() As String, _
        Optional ByVal sort As SortType = SortType.Asc, _
        Optional ByVal lngMin As Long = -1, _
        Optional ByVal lngMax As Long = -1)
    
    Dim i As Long
    Dim j As Long
    Dim vBase As String
    Dim vSwap As String
    
    If lngMin < 0 Then
        lngMin = LBound(argAry)
    End If
    
    If lngMax < 0 Then
        lngMax = UBound(argAry)
    End If
    
    vBase = argAry((lngMin + lngMax) \ 2)
    
    i = lngMin
    j = lngMax
    
    Do
        Do While StrComp(argAry(i), vBase) * sort < 0
            i = i + 1
        Loop
        
        Do While StrComp(argAry(j), vBase) * sort > 0
            j = j - 1
        Loop
        
        If i >= j Then
            Exit Do
        End If
        
        vSwap = argAry(i)
        argAry(i) = argAry(j)
        argAry(j) = vSwap
        
        i = i + 1
        j = j - 1
    Loop
    
    If lngMin < i - 1 Then
        SortByQuick argAry, sort, lngMin, i - 1
    End If
    
    If lngMax > j + 1 Then
        SortByQuick argAry, sort, j + 1, lngMax
    End If

End Sub
[VBA]シートの並べ替え
at 0 件のコメント:
Labels:

2020年11月26日木曜日

[VBA]複数のセルオブジェクトを１つのセルオブジェクトに統合する。

[はじめに]
・あまり知られていないかもしれませんが、
　複数のセルオブジェクトを、１つのセルオブジェクトに統合することができます。
　※Union関数を使用。

　統合後のセルに対して、
　プロパティやメソッドにアクセスすると、
　統合前のセルすべてに対して、アクセスすることと同じ意味になります。
　複数のセルオブジェクトをまとめて処理したい場合に、便利です。
　※［注意］セルの結合ではありません。

　以下は、
　「A1」、「B2:D5」、「D3,D5」の複数のセル領域を統合して、
　「Hello」の文字列を設定する例です。
　　備忘録としてサンプルソースを掲載します。

[ソース]
Private Sub UnionSample()

    Dim cellArray() As Variant
    Dim cellUnion As Range
    Dim cell As Variant
    
    '① 統合前のセルを定義
    cellArray = Array(Range("A1"), Range("B2:C5"), Range("D3:F5"))
    
    '② ①で定義したセルを
    '　 １つのセルオブジェクトに統合する。
    For Each cell In cellArray
        If cellUnion Is Nothing Then
            '初回のみセルを設定
            Set cellUnion = cell
        Else
            '2回目以降は、セルを統合する。
            Set cellUnion = Union(cellUnion, cell)
        End If
    
    Next
    
    '③ 統合後のセルに値を設定。
    cellUnion.Value = "Hello"

End Sub
[VBA]複数のセルオブジェクトを１つのセルオブジェクトに統合する。
at 0 件のコメント:
Labels:

2020年11月25日水曜日

[VBA]カラーの定数一覧

[はじめに]
・VBAで、
　色の定数を知りたいことがよくあるので、
　備忘録として掲載します。

カラーの定数一覧
ColorConstants定数
カラー例ColorConstants定数RGBカラー値
(R+G×256+B×2562)
黒■vbBlack0000
青■vbBlue0025516711680
シアン■vbCyan025525516776960
緑■vbGreen0255065280
マゼンタ■vbMagenta255025516711935
赤■vbRed25500255
白■vbWhite25525525516777215
黄■vbYellow255255065535


XlRgbColor定数
カラー例XlRgbColor定数RGBカラー値
(R+G×256+B×2562)
黒■rgbBlack0000
ディムグレー■rgbDimGray、rgbDimGrey1051051056908265
灰色■rgbGray、rgbGrey1281281288421504
濃い灰色■rgbDarkGray、rgbDarkGrey16916916911119017
銀色■rgbSilver19219219212632256
薄い灰色■rgbLightGray、rgbLightGrey21121121113882323
ゲーンズボロ■rgbGainsboro22022022014474460
ホワイトスモーク■rgbWhiteSmoke24524524516119285
白■rgbWhite25525525516777215
スノー■rgbSnow25525025016448255
ローズブラウン■rgbRosyBrown1881431439408444
薄いさんご■rgbLightCoral2401281288421616
インディアンレッド■rgbIndianRed20592926053069
茶■rgbBrown16542422763429
れんが色■rgbFireBrick17834342237106
栗色■rgbMaroon12800128
濃い赤■rgbDarkRed13900139
赤■rgbRed25500255
ミスティローズ■rgbMistyRose25522822514804223
サーモンピンク■rgbSalmon2501281147504122
トマト■rgbTomato25599714678655
濃いサーモンピンク■rgbDarkSalmon2331501228034025
さんご■rgbCoral255127805275647
オレンジレッド■rgbOrangeRed25569017919
薄いサーモンピンク■rgbLightSalmon2551601228036607
シェンナ■rgbSienna16082452970272
シーシェル■rgbSeashell25524523815660543
ピーチパフ■rgbPeachPuff25521818512180223
サンディブラウン■rgbSandyBrown244164966333684
リネン■rgbLinen25024023015134970
ペルー■rgbPeru205133634163021
ビスク■rgbBisque25522819612903679
濃いオレンジ■rgbDarkOrange255140036095
アンティークホワイト■rgbAntiqueWhite25023521514150650
タン■rgbTan2101801409221330
バーリーウッド■rgbBurlyWood2221841358894686
ブランシュアーモンド■rgbBlanchedAlmond25523520513495295
ナバホホワイト■rgbNavajoWhite25522217311394815
パパイヤホイップ■rgbPapayaWhip25523921314020607
モカシン■rgbMoccasin25522818111920639
オレンジ■rgbOrange255165042495
フローラルホワイト■rgbFloralWhite25525024015792895
オールドレース■rgbOldLace25324523015136253
小麦■rgbWheat24522217911788021
ゴールデンロッド■rgbGoldenrod218165322139610
濃いゴールデンロッド■rgbDarkGoldenrod18413411755384
コーンシルク■rgbCornsilk25524822014481663
ゴールド■rgbGold255215055295
レモンシフォン■rgbLemonChiffon25525020513499135
カーキ■rgbKhaki2402301409234160
濃いカーキ■rgbDarkKhaki1891831077059389
ペールゴールデンロッド■rgbPaleGoldenrod2382321077071982
アイボリー■rgbIvory25525524015794175
ベージュ■rgbBeige24524522014480885
明るい黄■rgbLightYellow25525522414745599
薄いゴールデンロッドイエロー■rgbLightGoldenrodYellow25025021013826810
オリーブ■rgbOlive128128032896
黄■rgbYellow255255065535
オリーブドラブ■rgbOliveDrab107142352330219
イエローグリーン■rgbYellowGreen154205503329434
濃いオリーブグリーン■rgbDarkOliveGreen85107473107669
グリーンイエロー■rgbGreenYellow173255473145645
若草色■rgbLawnGreen124252064636
シャルトルーズ■rgbChartreuse127255065407
ハニーデュー■rgbHoneydew24025524015794160
濃いシーグリーン■rgbDarkSeaGreen1431881439419919
明るい緑■rgbLightGreen1442381449498256
ペールグリーン■rgbPaleGreen15225115210025880
フォレストグリーン■rgbForestGreen34139342263842
ライムグリーン■rgbLimeGreen50205503329330
濃い緑■rgbDarkGreen0100025600
緑■rgbGreen0128032768
黄緑■rgbLime0255065280
淡いアクアマリン■rgbMediumAquamarine10225517011206502
淡いシーグリーン■rgbMediumSeaGreen601791137451452
シーグリーン■rgbSeaGreen46139875737262
ミントクリーム■rgbMintCream24525525016449525
スプリンググリーン■rgbSpringGreen02551278388352
淡いスプリンググリーン■rgbMediumSpringGreen025015410156544
アクアマリン■rgbAquamarine12725521213959039
ターコイズ■rgbTurquoise6422420813688896
薄いシーグリーン■rgbLightSeaGreen3217817011186720
淡いターコイズ■rgbMediumTurquoise7220920413422920
空色■rgbAzure24025525516777200
ペールターコイズ■rgbPaleTurquoise17523823815658671
濃いスレートグレー■rgbDarkSlateGray4779795197615
濃いスレートグレー■rgbDarkSlateGrey4779795197615
青緑■rgbTeal01281288421376
濃いシアン■rgbDarkCyan01391399145088
明るい水色■rgbLightCyan01391399145088
濃いターコイズ■rgbDarkTurquoise020620913749760
水色■rgbAqua025525516776960
カデットブルー■rgbCadetBlue9515816010526303
パウダーブルー■rgbPowderBlue17622423015130800
明るい青■rgbLightBlue17321623015128749
深いスカイブルー■rgbDeepSkyBlue019125516760576
スカイブルー■rgbSkyBlue13520623515453831
薄いスカイブルー■rgbLightSkyBlue13520625016436871
アリスブルー■rgbAliceBlue24024825516775408
スチールブルー■rgbSteelBlue7013018011829830
スレートグレー■rgbSlateGray1121281449470064
薄いスレートグレー■rgbLightSlateGray11913615310061943
ドジャーブルー■rgbDodgerBlue3014425516748574
薄いスチールブルー■rgbLightSteelBlue17619622214599344
コーンフラワーブルー■rgbCornflowerBlue10014923715570276
ロイヤルブルー■rgbRoyalBlue6510522514772545
ゴーストホワイト■rgbGhostWhite24824825516775416
ラベンダー■rgbLavender23023025016443110
ミッドナイトブルー■rgbMidnightBlue25251127346457
ネイビー■rgbNavy、rgbNavyBlue001288388608
濃い青■rgbDarkBlue001399109504
淡い青■rgbMediumBlue0020513434880
青■rgbBlue0025516711680
濃いスレートブルー■rgbDarkSlateBlue72611399125192
スレートブルー■rgbSlateBlue1069020513458026
淡いスレートブルー■rgbMediumSlateBlue12310423815624315
淡い紫■rgbMediumPurple14711221914381203
青紫■rgbBlueViolet1384322614822282
インディゴ■rgbIndigo7501308519755
濃いオーキッド■rgbDarkOrchid1535020413382297
濃い紫■rgbDarkViolet148021113828244
淡いオーキッド■rgbMediumOrchid1868521113850042
あざみ色■rgbThistle21619121614204888
プラム■rgbPlum22116022114524637
紫色■rgbViolet23813023815631086
紫■rgbPurple12801288388736
濃いマゼンタ■rgbDarkMagenta13901399109643
明るい紫■rgbFuchsia255025516711935
オーキッド■rgbOrchid21811221414053594
淡いバイオレットレッド■rgbMediumVioletRed199211338721863
深いピンク■rgbDeepPink255201479639167
ホットピンク■rgbHotPink25510518011823615
ラベンダーブラッシュ■rgbLavenderBlush25524024516118015
ペールバイオレットレッド■rgbPaleVioletRed2191121479662683
深紅■rgbCrimson22020603937500
ピンク■rgbPink25519220313353215
薄いピンク■rgbLightPink25518219312695295
at 0 件のコメント:
Labels:

2020年11月23日月曜日

[VBA]RGBカラー値からRGBの各々の値を取得

[はじめに]
・RGBの各要素からRGBカラー値を取得する為に、
　VBAではRGB関数が用意されていますが、
　その逆（RGBカラー値から元のRGB各要素を取得）の関数は
　用意されていません。

　たまに必要になることがあるので、
　ユーザ定義関数を作成しましたので、備忘録として掲載します。

[ソース]
'[機能]
'　RGB カラー値から、
'　赤(R)、緑(G)、青(B)の各々の値を取得する。
'[引数]
'　rgbColor：RGB カラー値
'[戻り値]
'　RGBの各値（配列）
'　　０番目：赤(R)
'　　１番目：緑(G)
'　　２番目：青(B)
Public Function GetRgbValues(ByVal rgbColor As Long) As Integer()

    Dim rtnColors(2) As Integer

    '赤(R)
    rtnColors(0) = rgbColor Mod 256
    '緑(G)
    rtnColors(1) = rgbColor \ 256 Mod 256
    '青(B)
    rtnColors(2) = rgbColor \ 65536

    GetRgbValues = rtnColors

End Function
[VBA]RGBカラー値から赤(R)、緑(G)、青(B)の各々の値を取得
at 0 件のコメント:
Labels:

2020年11月22日日曜日

[VBA]セルの取得、値の書き込み

[はじめに]
・Excel VBAでよくセルの情報を取得することがありますが、
　様々な書き方があるので、備忘録に記載します。

　セル座標をA1形式や行列番号で指定したり、
　複数セルの範囲指定、その他のブックやシート上のセルの取得　など
　用途に応じたパターンを適用頂ければと思います。

[ソース]
Private Sub WriteToCellValue()

    '■■■１．「Ａ１形式」でセルを指定する。
    '　①単一セルを扱う。
    '　※例：セルA1に値を出力
    Range("A1").Value = "あ"
    
    '　②複数セルを扱う（その１）
    '　※例：セルA3～A5に値を出力
    Range("A3:A5").Value = "い"

    '　③複数セルを扱う（その２）
    '　※例：セルC1～D10に値を出力
    Range(Range("C1"), Range("D10")).Value = "う"

    '■■■２．行番号、列番号でセルを指定する。
    '　行番号、列番号をカウントアップ等をさせたい場合、有効。
    '　※例：セル（1行目、6列目）に値を出力
    Cells(1, 6).Value = "え"

    '■■■３．特定のセル範囲内から、相対的にセルを取得
    '　※例：セルD4（B3～E5内で2行目、3列目）に値を出力
    Range("B3:E5").Cells(2, 3).Value = "お"

    '■■■４．特定のセル範囲内から、相対的な行を取得
    '　※例：B3～E5内の1行目に値を出力
    Range("B3:E5").Rows(1).Value = "か"

    '■■■５．特定のセル範囲内から、相対的な列を取得
    '　※B3～E5内の3列目に値を出力
    Range("B3:E5").Columns(3).Value = "き"

    '■■■６．他のシートのセルを扱う。
    '　指定セルが、他のシートにある場合は、
    '　以下のように記載します。
    '　シート省略時は、アクティブシートが対象になります。
    '　※例：シートSheet1のセルA2に値を出力
    '　　　以下例のRangeは上記の１～５の表記でも可能。
    Sheets("Sheet1").Range("A2").Value = "く"

    '■■■７．他のブックのセルを扱う。
    '　指定セルが、他のブック、シートにある場合は、
    '　以下のように記載します。
    '　ブック省略時は、アクティブブックが対象になります。
    '　※例：当ブックのシートSheet1のセルA3に値を出力
    '　　　以下例のRangeは上記の１～５の表記でも可能。
    ThisWorkbook.Sheets("Sheet1").Range("A3").Value = "け"

End Sub
[VBA]セルの選択
at 0 件のコメント:
Labels:

2015年9月20日日曜日

[VBA]クラスモジュールのインスタンス生成タイミングについて

[はじめに]
VBAは、Javaや.NET系言語程ではありませんが、
オブジェクト指向をサポートしています。

Javaや.NETとの違いの１つとして、
インスタンスの生成タイミングがあります。
Javaや.NETの感覚でコーディングすると間違いに陥りやすいので、
備忘録として記載します。

[インスタンスの生成タイミング]
インスタンスの生成はJavaなどでは、
『New』を指定するとインスタンスが生成されますが、
VBAでは記載の仕方によって、
必ずしも生成されるとは限りません。

例えば、Javaの場合、
newを指定するタイミングでインスタンスが生成され、
その参照が変数に格納されます。
クラスモジュールのインスタンス生成タイミング_java.png
それに対して、VBAの場合は、
Newを指定したタイミングではインスタンスは生成されず、
その変数に初めてアクセス（メソッド呼出しなど）するタイミングで、
インスタンスが生成されます。
クラスモジュールのインスタンス生成タイミング_vba.png
インスタンス生成タイミングの検証として、
下記のコードを実行してみると以下のようになります。
もし、Javaや.NETと同じように
宣言時にインスタンス生成がされるのであれば、
出力結果は、
　(1)インスタンスをNew付で宣言します。
　(a)インスタンスが生成されました。　★JavaやC#ならこのタイミング
　(2)これからインスタンスにアクセスします。
　(b)MethodA実行中
となるはずですが、
実際は次のようになります。
　(1)インスタンスをNew付で宣言します。
　(2)これからインスタンスにアクセスします。
　(a)インスタンスが生成されました。　★VBAの場合、初回メソッド実行時
　(b)MethodA実行中
これは、宣言時にインスタンスは作成しておらず、
MethodAを実行する際に、インスタンスが生成していることを示します。

[VBAのコード]
Option Explicit

Private Sub TestA()
    Dim a As New Hoge
    Debug.Print "(1)インスタンスをNew付で宣言します。"
    Debug.Print "(2)これからインスタンスにアクセスします。"
    a.MethodA

    '実行結果
    '(1)インスタンスをNew付で宣言します。
    '(2)これからインスタンスにアクセスします。
    '(a)インスタンスが生成されました。
    '(b)MethodA実行中
End Sub
[VBA]インスタンスの生成タイミングの検証（Hogeクラスの呼出し側）


Option Explicit

Private Sub Class_Initialize()
    Debug.Print "(a)インスタンスが生成されました。"
End Sub

Public Sub MethodA()
    Debug.Print "(b)MethodA実行中"
End Sub
[VBA]インスタンスの生成タイミングの検証（Hogeクラス）
[その他] 　VBAを例に説明していますが、 　VisualBasic6（VB6）系の言語にも同様なことが言えます。
at 0 件のコメント:
Labels:

2013年12月31日火曜日

[VBA]文字コードを指定してファイルにテキストを出力するクラスモジュール

[はじめに]
・最近、JSONファイルを扱うことがあり、
　UTF-8でテキストファイルを作成する機会があったので、
　作ってみました。
　備忘録としてサンプルを掲載します。
　クラスモジュールで定義することを前提としています。

[ソース]
''' <summary>
''' クラスモジュール名：TextWriterWithCharaSet
''' 文字コードを指定してファイルにテキストを出力するクラス
''' </summary>
''' <remarks></remarks>
Option Explicit

'ファイルのバッファサイズ
Private Const BUF_SIZE As Integer = 1024

'文字コード（デフォルト：UTF-8）
Public CharCode As String

'出力ディレクトリ
Public TargetDirectory As String

'出力ファイル名
Public TargetFileName As String

'FileSystemObject
Private objFs As Object

'ADODB.Stream
Private objStream As Object

'ADODB.StreamのSaveOptionsEnum
Private Enum SaveOptionsEnum
    'ファイルが存在しない場合にのみ作成します。
    '存在する場合はエラー。（既定値）
    adSaveCreateNotExist = 1
    'ファイルが存在する場合は、
    'ファイルを上書きします。
    adSaveCreateOverWrite = 2
End Enum

'出力テキストのコレクション
Private colTraget As New Collection

''' <summary>
''' Initializeイベント（コンストラクタ）
''' </summary>
''' <remarks></remarks>
Private Sub Class_Initialize()
    Set objStream = CreateObject("ADODB.Stream")
    Set objFs = CreateObject("Scripting.FileSystemObject")
    
    Me.CharCode = "UTF-8"
    
    Call ClearBuffer
End Sub

''' <summary>
''' Terminateイベント（デストラクタ）
''' </summary>
''' <remarks></remarks>
Private Sub Class_Terminate()
     
    Call Flush
    
    Set objStream = Nothing
    Set objFs = Nothing

End Sub

''' <summary>
''' テキストを出力する。
''' </summary>
''' <param name="strText">出力テキスト</param>
''' <param name="useBuffer">バッファの利用有無（※省略時はTrue）</param>
''' <remarks></remarks>
Public Sub WriteText( _
    ByVal strText As String, _
    Optional ByVal useBuffer As Boolean = True)
    
    colTraget.Add strText
    
    If useBuffer = True Then
        'バッファ有効の場合は、
        '一旦、バッファに溜めておき、
        '特定サイズを越えてからファイル出力する。
        If colTraget.Count > BUF_SIZE Then
            Me.Flush
        End If
    Else
        'バッファ無効の場合は、ファイルに出力
        Me.Flush
    End If

End Sub

''' <summary>
''' バッファーの内容をテキストに出力する。
''' </summary>
''' <remarks></remarks>
Public Sub Flush()
     
    Dim i As Long
    Dim targetFilePath As String
    
    On Error GoTo LBL_ERR:
     
    'ファイルパスを生成
    targetFilePath = objFs.BuildPath( _
        GetTargetDirectory(), TargetFileName)
    
    With objStream
        .Charset = Me.CharCode
        .Open
        
        'ファイルが既に存在する場合は、全テキストを読込む。
        '※追記書込みができないので、
        '  既存テキストをメモリ上に取込んでから上書きする。
        If objFs.FileExists(targetFilePath) Then
            .LoadFromFile targetFilePath
            .Position = .Size
        End If

        For i = 1 To colTraget.Count
            .WriteText colTraget(i)
        Next
        
        .SaveToFile targetFilePath, _
            SaveOptionsEnum.adSaveCreateOverWrite
        
        .Close
    
    End With
     
    Call ClearBuffer
    
    Exit Sub
LBL_ERR:
    
     Call ClearBuffer
     
     Err.Raise _
         Number:=Err.Number, _
         Description:="テキストの出力に失敗しました。" & _
         Err.Description

End Sub

''' <summary>
''' 出力ディレクトリを取得する。
''' </summary>
''' <returns>出力ディレクトリ（デフォルト：ThisWorkbook.path）</returns>
''' <remarks></remarks>
Private Function GetTargetDirectory() As String
     If Me.TargetDirectory = "" Then
         GetTargetDirectory = ThisWorkbook.path
         Exit Function
     End If

     GetTargetDirectory = Me.TargetDirectory

End Function

''' <summary>
''' 出力ファイルパスを設定する。
''' </summary>
''' <param name="targetFilePath">出力ファイルパス</param>
''' <remarks></remarks>
Public Sub SetFilePath(ByVal targetFilePath As String)
     
    With objFs
        Me.TargetDirectory = _
            .GetParentFolderName(targetFilePath)
        Me.TargetFileName = _
            objFs.GetFileName(targetFilePath)
    End With

End Sub

''' <summary>
''' バッファーをクリアする。
''' </summary>
''' <remarks></remarks>
Public Sub ClearBuffer()
     Dim i As Long
     
     For i = colTraget.Count To 1 Step -1
         colTraget.Remove i
     Next

End Sub
[VBA]文字コードを指定してファイルにテキストを出力するクラスモジュール

[ソース]
Private Sub CommandButton1_Click()

    Dim rw As New TextWriterWithCharaSet
    
    rw.CharCode = "UTF-8"
    rw.SetFilePath "C:\aaa\hogehoge.txt"
    rw.WriteText "ABCDE", True
    
    Set rw = Nothing
    
End Sub
[VBA]使用例
at 0 件のコメント:
Labels:

2013年9月1日日曜日

[VBA]ログを出力するクラスモジュール

[はじめに]
・最近、Excelマクロを使う機会が増えたので、
　備忘録としてサンプルを掲載します。
　クラスモジュールで定義することを前提としています。

[ソース]
''' <summary>
''' クラスモジュール名：LogForExcel
''' ログ出力を制御するクラス
''' </summary>
''' <remarks></remarks>
Option Explicit

'ログファイルのプレフィックス
Private Const LOG_FILE_PREFIX As String = "LOG_"
'ログファイルの拡張子
Private Const LOG_FILE_EXTENSION As String = ".log"
'ログファイルのバッファサイズ
Private Const LOG_BUF_SIZE As Integer = 1024

'ログ出力ディレクトリ
Public LogDirectory As String

'FileSystemObject
Private objFs As Object

'TextStreamObjectのIOモード
Private Enum IOMode
    ForReading = 0  '読み取り専用モード（既定値）
    ForWriting = 1  '上書きモード
    ForAppending = 8    '追記モード
End Enum

'ログ出力対象
Private colTraget As New Collection

''' <summary>
''' Initializeイベント（コンストラクタ）
''' </summary>
''' <remarks></remarks>
Private Sub Class_Initialize()
    Set objFs = CreateObject("Scripting.FileSystemObject")
    
    Call ClearLog
End Sub

''' <summary>
''' Terminateイベント（デストラクタ）
''' </summary>
''' <remarks></remarks>
Private Sub Class_Terminate()
    
    Call Flush
    
    Set objFs = Nothing

End Sub

''' <summary>
''' ログを出力する。[Information]
''' </summary>
''' <param name="msg">出力メッセージ</param>
''' <param name="useBuffer">バッファの利用有無</param>
''' <remarks></remarks>
Public Sub OutputInfo( _
    ByVal msg As String, _
    Optional ByVal useBuffer As Boolean = False)
    
    Call OutputLog("Informaton", msg, useBuffer)
    
End Sub

''' <summary>
''' ログを出力する。[Warning]
''' </summary>
''' <param name="msg">出力メッセージ</param>
''' <param name="useBuffer">バッファの利用有無</param>
''' <remarks></remarks>
Public Sub OutputWarn( _
    ByVal msg As String, _
    Optional ByVal useBuffer As Boolean = False)
    
    Call OutputLog("Warning", msg, useBuffer)
    
End Sub

''' <summary>
''' ログを出力する。[Error]
''' </summary>
''' <param name="msg">出力メッセージ</param>
''' <param name="objErr">エラーオブジェクト</param>
''' <param name="useBuffer">バッファの利用有無</param>
''' <remarks></remarks>
Public Sub OutputError( _
    ByVal msg As String, _
    Optional ByVal objErr As ErrObject = Nothing, _
    Optional ByVal useBuffer As Boolean = False)
    
    Dim strMsg As String
    
    strMsg = msg
    
    If Not (objErr Is Nothing) Then
        strMsg = strMsg & ":" & _
            "Err.Number:[" & objErr.Number & "]," & _
            "Err.Description:[" & objErr.Description & "]:"
    End If
    
    Call OutputLog("Error", strMsg, useBuffer)

End Sub

''' <summary>
''' ログを出力する。
''' </summary>
''' <param name="logType">ログ種別</param>
''' <param name="msg">出力メッセージ</param>
''' <param name="useBuffer">バッファの利用有無</param>
''' <remarks></remarks>
Private Sub OutputLog( _
    ByVal logType As String, _
    ByVal msg As String, _
    ByVal useBuffer As Boolean)

    colTraget.Add _
        Format(Now, "yyyy/mm/dd hh:mm:ss") & ":" & _
        logType & ":" & msg

    If useBuffer = True Then
        If colTraget.Count > LOG_BUF_SIZE Then
            'バッファがサイズを超えた場合は、ファイルに出力
            Me.Flush
        End If
    Else
        'バッファ無効の場合は、ファイルに出力
        Me.Flush
    End If

End Sub

''' <summary>
''' バッファーのデータをログに出力する。
''' </summary>
''' <remarks></remarks>
Public Sub Flush()
    
    Dim objTs As Object 'TextStreamObject
    Dim i As Long
    
    On Error GoTo LBL_ERR:
    
    Set objTs = objFs.OpenTextFile( _
        fileName:=objFs.BuildPath( _
            GetLogDirectory(), _
            LOG_FILE_PREFIX & _
            Format(Now, "yyyymmdd") & _
            LOG_FILE_EXTENSION), _
        IOMode:=IOMode.ForAppending, _
        Create:=True)


    For i = 1 To colTraget.Count
        objTs.WriteLine colTraget(i)
    Next
    
    objTs.Close
    Set objTs = Nothing
    Call ClearLog

   Exit Sub
LBL_ERR:
   
    If Not (objTs Is Nothing) Then
        objTs.Close
        Set objTs = Nothing
    End If
    
    Call ClearLog
    
    Err.Raise _
        Number:=Err.Number, _
        Description:="ログの出力に失敗しました。" & _
        Err.Description

End Sub

''' <summary>
''' ログ出力ディレクトリを取得する。
''' </summary>
''' <returns>ログ出力ディレクトリ（デフォルト：ThisWorkbook.path）</returns>
''' <remarks></remarks>
Private Function GetLogDirectory() As String
    If Me.LogDirectory = "" Then
        GetLogDirectory = ThisWorkbook.Path
        Exit Function
    End If
    
    GetLogDirectory = Me.LogDirectory

End Function

''' <summary>
''' バッファーをクリアする。
''' </summary>
''' <remarks></remarks>
Public Sub ClearLog()
    Dim i As Long
    
    For i = colTraget.Count To 1 Step -1
        colTraget.Remove i
    Next

End Sub
[VBA]ログを出力するクラスモジュール


[ソース]
Private Sub CommandButton1_Click()

    Dim logger As New LogForExcel
    
    On Error GoTo LBL_ERR
    
    'ログ出力[Info]
    Call logger.OutputInfo("出力テスト（Info）", True)
    'ログ出力[Warn]
    Call logger.OutputWarn("出力テスト（Warn）", True)
    
    'ゼロ除算で意図的に例外を発生させる。
    Debug.Print 1 / 0
    
    Set logger = Nothing
    
    Exit Sub
LBL_ERR:
    
    'ログ出力[Error]
    Call logger.OutputError("出力テスト（Error）", Err, True)
    
    Set logger = Nothing

End Sub
[VBA]使用例
at 0 件のコメント:
Labels:

2013年8月18日日曜日

[VBA]ファイル保存ダイアログの表示

[はじめに]
・最近、Excelマクロを使う機会が増えたので、
　備忘録としてサンプルを掲載します。
　VBAの関数が使いにくいので、クラスモジュールにまとめてみました。
　.NETのSaveFileDialogクラスを真似して実装しているので、
　.NET開発者にとっては、お馴染みのインタフェースで使いやすいかと思います。

[ソース]
''' <summary>
''' クラスモジュール名：SaveFileDialog
''' ファイル保存ダイアログを制御するクラス
''' </summary>
''' <remarks></remarks>
Option Explicit

'FileSystemPbject
Private objFs As Object

'タイトル
Public Title As String
'初期ディレクトリ
Public InitialDirectory As String
'初期ファイル名
Public InitialFileName As String
'[ファイルの種類]の選択肢
Public Filter As String
'[ファイルの種類]の選択値
Public FilterIndex As Integer

'選択したファイル名
Private m_FileName As String

''' <summary>
''' Initializeイベント（コンストラクタ）
''' </summary>
''' <remarks></remarks>
Private Sub Class_Initialize()
    Set objFs = CreateObject("Scripting.FileSystemObject")
    
    Call Clear
End Sub

''' <summary>
''' Terminateイベント（デストラクタ）
''' </summary>
''' <remarks></remarks>
Private Sub Class_Terminate()
    Set objFs = Nothing
End Sub


''' <summary>
''' 初期化
''' </summary>
''' <remarks></remarks>
Public Sub Clear()
    
    Me.InitialDirectory = Application.ThisWorkbook.path
    Me.InitialFileName = ""
    Me.Filter = "すべてのファイル(*.*),*.*"
    Me.FilterIndex = 1
    Me.Title = ""
    m_FileName = "ファイル名を指定してください"

End Sub

''' <summary>
''' フィルターを設定
''' </summary>
''' <param name="filterArray">フィルター文字列</param>
''' <remarks></remarks>
Public Sub SetFilterList(ParamArray filterArray() As Variant)
    Filter = Join(filterArray, ",")
End Sub

''' <summary>
''' 選択したファイル名を取得する。
''' </summary>
''' <remarks></remarks>
Public Function GetSelectedFileName() As String
    GetSelectedFileName = m_FileName
End Function

''' <summary>
''' パスとファイル名を結合する。
''' </summary>
''' <param name="path">パス</param>
''' <param name="fileName">ファイル名</param>
''' <returns>結合後のフルパス</returns>
''' <remarks></remarks>
Private Function BuildPath( _
    ByVal path As String, _
    ByVal fileName As String) As String
    
    BuildPath = objFs.BuildPath(path, fileName)

End Function

''' <summary>
''' ファイル保存ダイアログを開く
''' </summary>
''' <returns>vbOK：ファイル選択、vbCancel：キャンセル</returns>
''' <remarks></remarks>
Public Function ShowDialog() As VbMsgBoxResult

    Dim resDlg As Variant
    Dim initDir As String
    
    '初期ディレクトリの存在チェック
    ' 存在しない場合は、Excelブックの配置ディレクトリに置き換える。
    If objFs.FolderExists(Me.InitialDirectory) = False Then
        Me.InitialDirectory = ThisWorkbook.path
    End If
    
    'ファイル選択ダイアログを開く
    resDlg = _
         Application.GetSaveAsFilename( _
              InitialFileName:= _
                BuildPath( _
                    Me.InitialDirectory, _
                    Me.InitialFileName), _
              FileFilter:=Me.Filter, _
              FilterIndex:=Me.FilterIndex, _
              Title:=Me.Title _
             )

    If resDlg = False Then
        'キャンセルした場合
        m_FileName = ""
        
        ShowDialog = vbCancel
        Exit Function
    End If
    
    'ファイル選択した場合
    m_FileName = resDlg
    
    ShowDialog = vbOK
    Exit Function
    
End Function
VBA]ファイル保存ダイアログ


[ソース]
Private Sub CommandButton1_Click()

    Dim sfd As New SaveFileDialog
    
    With sfd
        .InitialDirectory = "C:\Hoge"
        .InitialFileName = "abc.csv"
        .Title = "タイトル"
        .FilterIndex = 1
        .SetFilterList "CSV(*.csv),*.csv", "すべてのファイル(*.*),*.*"
        
    End With
    
    'ファイル保存ダイアログを開く。
    If sfd.ShowDialog() = vbOK Then
        MsgBox sfd.GetSelectedFileName()
    Else
        MsgBox "キャンセルしました"
    End If
    
    '終了処理
    Set sfd = Nothing

End Sub
VBA]使用例
at 0 件のコメント:
Labels:
登録: 投稿 (Atom)

[雑記]ドローン（DJI Mini 3）

（１）雑記 もともと多趣味の友人 masakazu Drone 氏が、 最近、 ドローン にハマり始めて、 更に、新たな趣味が増えたとのこと。 ドローン を始めてから、 まだ1年も経っていないとのことですが、 旅行先で山や川の景色を 空撮 して、 Youtube ...

  • [雑記]ドローン（DJI Mini 3）
    （１）雑記 もともと多趣味の友人 masakazu Drone 氏が、 最近、 ドローン にハマり始めて、 更に、新たな趣味が増えたとのこと。 ドローン を始めてから、 まだ1年も経っていないとのことですが、 旅行先で山や川の景色を 空撮 して、 Youtube ...
  • [Book's Review (Develop)]Java言語で学ぶデザインパターン入門第３版
    （１）レビュー 　10年以上前からある書籍ですが、昨今のJavaのバージョンに合わせて、 　リニューアルされましたので、改めて紹介いたします。 　GOFが提唱したデザインパターンについて、とてもわかりやすくまとめた１冊です。 　各パターンを章毎にまとめてあり、クラス図・...
  • [SQLServer]sqlcmdコマンドの表示桁数の指定
    （１）はじめに 　 sqlcmd コマンドで、 　SELECTステートメントを実行した時、 　行の折り返しで、結果が見づらくなることがあります。 　 Oracle の LINESIZE に相当する設定が、 　 SQLServer にもないか調べてみました。 　普段...
  • [Hardware's Review]SEIKO CLOCK (セイコークロック) デジタル ウィークリーアラーム
    （１）レビュー 　目覚まし時計の調子が悪くなったので、新たに購入しました。 　指定した時刻にアラームが鳴ってくれさえすればよいので、 　特別な機能は求めていなかったのですが、 　価格の割に便利な機能が搭載されていたので、購入に至りました。 　最近は、スマホにもアラーム...
  • [Algo]和と積から元の２数の算出
    [はじめに] （１） ある２数の和と積から、元の２数を求めるアルゴリズム です。 　　　例えば、『 足して５ 』、『 掛けて６ 』になる２つの数は、 　　　 ２ と ３ になります。 　　　これを解くアルゴリズムとして、 　　　 ２次方程式の解の解法 を利用することがで...
  • [Book's Review (Develop)]ASP.NET MVC 5実践プログラミング
    （１）レビュー 　 ASP.NET は、以下の2種類に大別されます。 　 （１）ASP.NET Web Form 　　　.NET Framework1.0リリース時の頃から導入 　 （２）ASP.NET MVC 　　　.NET Framework4以降に導入 　...
  • [VBA]Excelのシートを並べ替え
    [はじめに] Excelでシートを昇順に並べ替える機会があったので、 備忘録としてサンプルソースを掲載します。 サンプルは昇順ソートですが、引数を変更すると降順にも対応できるようにしています。 [ソース] コードのコピー Optio...
  • [Book's Review (Develop)]独習JavaScript 新版
    （１）レビュー 　JavaScriptは古くからあり、時代と共に進化してきています。 　JavaScriptの独習シリーズは過去にもありましたが、 　最近（2021年）、独習シリーズでJavaScriptの新版が登場しました。 　 クラス 、 反復処理 、 非同期処理 ...
  • [.NET][Edge対応版]プログラムコードの変換（C#、VB.NET→HTML）
    [はじめに] 　・プログラムソース（C#、VB.NET）を 　　ブログ公開用のHTMLに変換するツールです。 　　（コード量が膨大の為、変換処理のみ掲載しています。） [機能] 　　プログラムソースの文字列を、HTMLに変換する。 　　変換後のHTMLは、<ta...
  • [Tool's Review]ステンレスものほし台 ブロー台付き BD-50S 【ブロー台付きで安定性抜群・U型の竿受けで竿の取り外し楽々! 】
    （１）レビュー 　最近、引越しをしました。 　ベランダの物干し竿を固定する位置が転居前よりも高く、 　身長が低い妻にとって家事がしづらいので、 　 物干し台 を購入しました。 　 　組み立て式の為、多少のぐらつきはありますが、 　実際使ってみても全く不便さを感じませ...