So-net無料ブログ作成
検索選択
Programming ExcelVBA ブログトップ

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

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

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

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

VBAでは、インスタンスの宣言時にNewを指定することができます。
Newを指定しているのでこの時点で
インスタンスが生成されると思われがちですが、
実際は、宣言以降のステートメントで、
最初にインスタンス変数に
アクセスするタイミングで生成されます。

インスタンス生成タイミングの検証として、
下記のコードを実行してみました。
もし、Javaや.NETと同じように
宣言時にインスタンス生成がされるのであれば、
出力結果は、
 (1)インスタンスをNew付で宣言します。
 (a)インスタンスが生成されました。
 (2)これからインスタンスにアクセスします。
 (b)MethodA実行中
となるはずですが、
実際は次のようになります。
 (1)インスタンスをNew付で宣言します。
 (2)これからインスタンスにアクセスします。
 (a)インスタンスが生成されました。
 (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)系の言語にも同様なことが言えます。

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

[はじめに]
・最近、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">バッファの利用有無</param>
''' <remarks></remarks>
Public Sub WriteText( _
    ByVal strText As String, _
    Optional ByVal useBuffer As Boolean = False)
    
    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]使用例

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

[はじめに]
・最近、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 NothingThen
        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 NothingThen
        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]使用例

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

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

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

'FileSystemPbject
Private objFs As Object
'WScript.Shell
Private objWs 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")
    Set objWs = CreateObject("WScript.Shell")
    
    Call Clear
End Sub

''' <summary>
''' Terminateイベント(デストラクタ)
''' </summary>
''' <remarks></remarks>
Private Sub Class_Terminate()
    Set objFs = Nothing
    Set objWs = 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 CombinePath( _
    ByVal path As String, _
    ByVal fileName As StringAs String
    
    CombinePath = objFs.BuildPath(path, fileName)

End Function

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

    Dim resDlg As Variant
    
    'カレントディレクトリを設定
    objWs.CurrentDirectory = Me.InitialDirectory

    'ファイル選択ダイアログを開く
    resDlg = _
         Application.GetSaveAsFilename( _
              InitialFileName:= _
                CombinePath( _
                    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
        .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]使用例

[VBA]ファイル選択ダイアログの表示 [Programming ExcelVBA]

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

[ソース]
コードのコピー
''' <summary>
''' クラスモジュール名:OpenFileDialog
''' ファイル選択ダイアログを制御するクラス
''' </summary>
''' <remarks></remarks>
Option Explicit

'FileSystemPbject
Private objFs As Object
'WScript.Shell
Private objWs As Object

'タイトル
Public Title As String
'初期ディレクトリ
Public InitialDirectory As String
'[ファイルの種類]の選択肢
Public Filter As String
'[ファイルの種類]の選択値
Public FilterIndex As Integer
'複数選択の可否
Public MultiSelect As Boolean

'選択したファイル名
Private m_FileNames() As String

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

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

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

    ReDim m_FileNames(0)
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 GetSelectedFileNames() As String()
    GetSelectedFileNames = m_FileNames
End Function

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

    Dim resDlg As Variant

    'カレントディレクトリを設定
    objWs.CurrentDirectory = Me.InitialDirectory
     
    'ファイル選択ダイアログを開く
    resDlg = _
         Application.GetOpenFilename( _
              FileFilter:=Me.Filter, _
              FilterIndex:=Me.FilterIndex, _
              Title:=Me.Title, _
              MultiSelect:=Me.MultiSelect _
             )

    If IsArray(resDlg) = False Then
        If resDlg = False Then
            'キャンセルした場合
            ReDim m_FileNames(0)
            
            ShowDialog = vbCancel
            Exit Function
        End If
    End If
    
    ReDim m_FileNames(0)
    
    'ファイル選択した場合
    If IsArray(resDlg) = True Then
        '複数選択の場合
        Dim cnt_i As Integer
        
        For cnt_i = 1 To UBound(resDlg)
            ReDim Preserve m_FileNames(cnt_i - 1)
            m_FileNames(cnt_i - 1) = resDlg(cnt_i)
        Next
        
        ShowDialog = vbOK
        Exit Function
    Else
        '単一選択の場合
        ReDim m_FileNames(0)
        m_FileNames(0) = resDlg
    
        ShowDialog = vbOK
        Exit Function
    End If
    
End Function
[VBA]ファイル選択ダイアログ

[ソース]
コードのコピー
Private Sub CommandButton1_Click()
    
    Dim ofd As New OpenFileDialog
    
    With ofd
        .Title = "ファイル選択ダイアログ(単一選択)"
        .FilterIndex = 1
        .MultiSelect = False
        .SetFilterList "CSV(*.csv),*.csv""すべてのファイル(*.*),*.*"
        
    End With
    
    'ファイル選択ダイアログを開く。
    If ofd.ShowDialog() = vbOK Then
        
        Dim cntI As Integer
        Dim fList() As String
        
        fList = ofd.GetSelectedFileNames()
        
        For cntI = 0 To UBound(fList)
            MsgBox fList(cntI)
        Next
    Else
        MsgBox "キャンセルしました"
    End If

    '終了処理
    Set ofd = Nothing

End Sub
[VBA]使用例

[VBA]指定したブック内のシート検索 [Programming ExcelVBA]

[はじめに]
・最近、Excelマクロを使う機会が増えたので、備忘録としてサンプルを掲載します。
 指定したブック内のシートを検索する処理です。

[ソース]
コードのコピー
Option Explicit

''' <summary>
''' 指定したブック検索する。
''' </summary>
''' <param name="bookName">ブック名</param>
''' <returns>対象のWorkBook。(存在しない場合はNothing)</returns>
''' <remarks></remarks>
Public Function FindBook( _
    ByVal bookName As StringAs Workbook

    Dim bk As Workbook
    
    For Each bk In Workbooks
        If bk.name = bookName Then
            Set FindBook = Workbooks(bk.name)
            Exit Function
        End If
    Next

End Function

''' <summary>
''' 指定したブック内のシートを検索する。
''' </summary>
''' <param name="sheetName">シート名</param>
''' <param name="bookName">ブック名(※省略時はThisWorkbook.Name)</param>
''' <returns>対象のWorkSheet。(存在しない場合はNothing)</returns>
''' <remarks></remarks>
Public Function FindSheet( _
    ByVal sheetName As String, _
    Optional ByVal bookName As String = ""As Worksheet

    Dim bk As Workbook
    Dim sht As Worksheet

    If bookName = "" Then
        'ブック名を省略した場合は、
        '自分自身のブックを対象とする。
        Set bk = ThisWorkbook
    Else
        Set bk = FindBook(bookName)
        
        If bk Is Nothing Then
            '指定したブック名が存在しない場合は、Nothingを返す。
            Set FindSheet = Nothing
            Exit Function
        End If
        
    End If
    
    For Each sht In bk.Sheets
        If sht.name = sheetName Then
            Set FindSheet = bk.Worksheets(sht.name)
            Exit Function
        End If
    Next

    'シートが存在しない場合、Nothingを返す。
    Set FindSheet = Nothing

End Function
[VBA]指定したブック内のシートを検索

[VBA]罫線描画&罫線消去 [Programming ExcelVBA]

[はじめに]
Excelマクロで罫線描画、罫線消去を実装することがよくあります。
 『マクロの記録』で簡単に作れますが、汎用性がないので関数化しました。
 機能は単純に、セル範囲に罫線(外枠、内側の境界線)を描画するだけです。
 とりあえず、備忘録として載せておきます。

[ソース]
コードのコピー
Option Explicit

''' <summary>
''' 指定したセル範囲に罫線を描画する。(外枠、内側の境界線)
''' </summary>
''' <param name="targetRange">対象セル範囲</param>
''' <remarks></remarks>
Public Sub DrawLine(ByVal targetRange As Range)
    With targetRange
    
        '個々のセルの右上がり斜線
        .Borders(xlDiagonalUp).LineStyle = xlNone
        
        '個々のセルの右下がり斜線
        .Borders(xlDiagonalDown).LineStyle = xlNone
        
        'セル範囲の最上端
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThin
        End With
        
        'セル範囲の最下端
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThin
        End With
        
        'セル範囲の最左端
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThin
        End With
        
        'セル範囲の最右端
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThin
        End With
        
        If .Cells(1).Row < .Cells(.Count).Row Then
            'セル範囲の上下端以外の境界線
            '【注意(Excel2003以前のみ】
            ' セル範囲が複数行にわたる場合のみ処理します。
            ' 単数行の場合に処理するとエラーになることがあります。
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
        End If

        If .Cells(1).Column < .Cells(.Count).Column Then
            'セル範囲の左右端以外の境界線
            '【注意(Excel2003以前のみ】
            ' セル範囲が複数列にわたる場合のみ処理します。
            ' 単数列の場合に処理するとエラーになることがあります。
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
        End If

    End With

End Sub

''' <summary>
''' 指定したセル範囲の罫線を消去する。(外枠、内側の境界線)
''' </summary>
''' <param name="targetRange">対象セル範囲</param>
''' <remarks></remarks>
Public Sub EraseLine(ByVal targetRange As Range)
    
    With targetRange
        
        '個々のセルの右上がり斜線
        .Borders(xlDiagonalUp).LineStyle = xlNone
        
        '個々のセルの右下がり斜線
        .Borders(xlDiagonalDown).LineStyle = xlNone
        
        'セル範囲の最上端
        .Borders(xlEdgeTop).LineStyle = xlNone
        
        'セル範囲の最下端
        .Borders(xlEdgeBottom).LineStyle = xlNone
        
        'セル範囲の最左端
        .Borders(xlEdgeLeft).LineStyle = xlNone
        
        'セル範囲の最右端
        .Borders(xlEdgeRight).LineStyle = xlNone
        
        If .Cells(1).Row < .Cells(.Count).Row Then
            'セル範囲の上下端以外の境界線
            '【注意(Excel2003以前のみ)】
            ' セル範囲が複数行にわたる場合のみ処理します。
            ' 単数行の場合に処理するとエラーになります。
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End If
        
        If .Cells(1).Column < .Cells(.Count).Column Then
            'セル範囲の左右端以外の境界線
            '【注意(Excel2003以前のみ)】
            ' セル範囲が複数列にわたる場合のみ処理します。
            ' 単数列の場合に処理するとエラーになることがあります。
            .Borders(xlInsideVertical).LineStyle = xlNone
        End If
        
    End With

End Sub
[ExcelVBA]罫線の描画&消去

コードのコピー
Private Sub CommandButton1_Click()
    '罫線描画
    Call DrawLine(Selection)
End Sub

Private Sub CommandButton2_Click()
    '罫線消去
    Call EraseLine(Selection)
End Sub
[ExcelVBA]呼び出し例

[VBA]ExcelVBAでオブジェクト指向の継承 [Programming ExcelVBA]

[ポイント]
ExcelのVBA(Visual Basic for Application)は、
 完全オブジェクト指向言語(JavaやC#等)ほどではないが、
 オブジェクト指向によるプログラミングをサポートしています。
 『オブジェクト指向』と言えば、
 代表的な性質として以下の3つのキーワードがあります。
代表的な性質
継承
2つのクラス間で親子関係を持ち、子クラスが親クラスの性質を受け継ぐこと。
カプセル化
オブジェクト内部のデータを隠蔽したり(データ隠蔽)、オブジェクトの振る舞いを隠蔽したり、
オブジェクトの実際の型を隠蔽したりすることをいう。
多態性(ポリモフィズム)
実行される処理の実体が、コールされたメッセージではなく、メッセージを受けたオブジェクトに
よって決定される性質。
また、この性質を使って、
「同一のメッセージを使って、オブジェクトごとに異なった処理を行わせること」

[VBAのオブジェクト指向]
 VBAのオブジェクト指向は、完全オブジェクト指向言語(JavaやC#等)のそれと比べると、
 『子クラスのメソッドを経由して親クラスの変数やメソッドにアクセスできない』、
 『子クラス内から親クラスの変数やメソッドにアクセスできない』等の制限事項がある。
[多態性(ポリモフィズム)]
 『多態性(ポリモフィズム)』の説明で、
 『動物』に『鳴く』メッセージを通知する例がよく挙げられる。
 以下に、『多態性(ポリモフィズム)』を利用したサンプルコードを示す。
[クラス図]
クラス図
[クラスの説明]
Mammalクラス
 哺乳類を表すクラス。
 メソッドとして、Cry()を実装。
Dogクラス、Catクラス、Crowクラス
 イヌ、ネコ、カラスを表すクラス。各々のクラスはMammal(哺乳類)クラスを継承。
 メソッドとして、Mammal_Cry()を実装。
 ([親クラス名]_[親クラスのメソッド名]で、親クラスのメソッドをオーバーライドできます。)
[多態性(ポリモフィズム)]
・Dogオブジェクト、Catオブジェクト、Crowオブジェクトを
 Mammalオブジェクトの配列に格納する。
 MammalオブジェクトのCrowメソッドを経由して、
 Dogオブジェクト、Catオブジェクト、CrowオブジェクトのCrowメソッドを呼ぶ。
 以下のサンプルでは、3つのMammalオブジェクトのCryメソッドを呼んでいるが、
 実際に実行されるのは、Dog、Cat、CrowのMammal_Cryメソッドであることを示している。
 同一のCryというメッセージをMammalオブジェクトに通知しているが、
 受け取った各々のオブジェクト毎に異なった動作をしていることになる。(多態性(ポリモフィズム))
[サンプルコード]
コードのコピー
Option Explicit
'[クラス名] Mammalクラス
'[説明] 哺乳類を表すクラス
'       Dog(イヌ)、Cat(ネコ)、Crow(カラス)の
'       親クラスとして利用

'[メソッド名]
'   Cry
'[機能]
'   動物の鳴き声を取得します。
'[前提条件]
'   子クラスでオーバーライドして下さい。
Function Cry() As String
    Err.Raise _
        999, , _
        "このクラスのメソッドは直接呼ぶことはできません。" & vbCrLf & _
        "子クラスでオーバーライドして呼んで下さい。" 
End Function
[ExcelVBA]Mammalクラス

コードのコピー
Option Explicit
'[クラス名] Dogクラス
'[説明] イヌを表すクラス

'Mammalクラスを実装
Implements Mammal

'[メソッド名]
'   Mammal_Cry
'[機能]
'   動物の鳴き声を取得します。
'[備考]
'   メソッド名は、「親クラス名」_「メソッド名」
Public Function Mammal_Cry() As String
    Mammal_Cry = "ワンワン"
End Function
[ExcelVBA]Dogクラス

コードのコピー
Option Explicit
'[クラス名] Catクラス
'[説明] ネコを表すクラス

'Mammalクラスを実装
Implements Mammal

'[メソッド名]
'   Mammal_Cry
'[機能]
'   動物の鳴き声を取得します。
'[備考]
'   メソッド名は、「親クラス名」_「メソッド名」
Public Function Mammal_Cry() As String
    Mammal_Cry = "ニャー"
End Function
[ExcelVBA]Catクラス

コードのコピー
Option Explicit
'[クラス名] Crowクラス
'[説明] カラスを表すクラス

'Mammalクラスを実装
Implements Mammal

'[メソッド名]
'   Mammal_Cry
'[機能]
'   動物の鳴き声を取得します。
'[備考]
'   メソッド名は、「親クラス名」_「メソッド名」
Public Function Mammal_Cry() As String
    Mammal_Cry = "カァーカァー"
End Function
[ExcelVBA]Crowクラス

コードのコピー
Private Sub CommandButton1_Click()

    '哺乳類のオブジェクト変数を宣言
    '要素数3つの配列を用意
    Dim man(2) As Mammal
    
    'イヌ、ネコ、カラスの
    'オブジェクトを生成
    Set man(0) = New Dog
    Set man(1) = New Cat
    Set man(2) = New Crow
    
    '各々の動物の鳴き声を表示
    MsgBox man(0).Cry()
    MsgBox man(1).Cry()
    MsgBox man(2).Cry()

    'オブジェクトを解放
    Set man(0) = Nothing
    Set man(1) = Nothing
    Set man(2) = Nothing

End Sub
[ExcelVBA]呼び出し元

[実行結果]
多態性(ポリモフィズム)の実行結果
Programming ExcelVBA ブログトップ
メッセージを送る

この広告は前回の更新から一定期間経過したブログに表示されています。更新すると自動で解除されます。