オブジェクト名を指定してWorksheetオブジェクトを取得するFunction(Excel)

オブジェクト名を指定してWorksheetオブジェクトを取得するFunction(Excel)

CodeNameプロパティというものがある

akashi-keirin.hatenablog.com

コチラの記事のコメント欄が炎上wしたことにより、CodeNameというプロパティの存在を知った。

CodeNameプロパティとは

Worksheet.CodeNameで、Worksheetオブジェクトのオブジェクト名(デフォルトでVBEのプロジェクト エクスプローラーに表示される「Sheet1(Sheet1)」の左側の「Sheet1」。シート名を変えてもオブジェクト名は変わらない。プロジェクト エクスプローラー上で変更可能。)

オブジェクト名は、手動でシート名を変更されても変化しないので、ユーザーによる勝手なシート名の変更にも耐えられる可能性が高い、ということだ。

もちろん、わざわざVBEを開いてオブジェクト名を変更するような猛者がいれば別だがw

たとえば、テスト用ブックの各ワークシートのオブジェクト名を

f:id:akashi_keirin:20190511091527j:plain

こんなふうにしておいて、イミディエイト・ウインドウに

?Worksheets("アホ").CodeName

と打ち込んで[Enter]してみると、

f:id:akashi_keirin:20190511091529j:plain

このように、オブジェクト名「Sh01Aho」が返っている。

つまり、そういうことだ。

オブジェクト名を指定してWorksheetオブジェクトを取得する

Excelで様式を配布して、それを回収するような場合、配布前に必要なシートのオブジェクト名を適当なものに変更しておけば、見かけ上シート名をいじくられていてもCodeNameプロパティの値をキーに必要なシートを特定することができる。

リスト1 標準モジュール
Public Function getWorksheetByCodeName( _
            ByVal targetBook As Workbook, _
            ByVal targetCodeName As String) As Worksheet
  Dim ret As Worksheet
  Set ret = Nothing
  Dim i As Long
  For i = 1 To targetBook.Worksheets.Count
    With targetBook
      If .Worksheets(i).CodeName = targetCodeName Then _
        Set ret = .Worksheets(i): Exit For
    End With
  Next
  Set getWorksheetByCodeName = ret
  Set ret = Nothing
End Function

Workbookオブジェクトとオブジェクト名を受け取り、指定したオブジェクト名のWorksheetオブジェクトがあればそれを返し、なければNothingが返るしくみ。

使ってみる

ThisWorkbookの同一フォルダ内にテスト用ブック「Test2.xlsx」を置いて、次のコードで実験。

スト2 標準モジュール
Public Sub test02()
  Dim targetBook As Workbook
  Set targetBook = Workbooks.Open(ThisWorkbook.Path & "\Test2.xlsx")
  Dim targetSh As Worksheet
  Set targetSh = getWorksheetByCodeName(targetBook, "Sh05Dekosuke")
  If Not targetSh Is Nothing Then Debug.Print targetSh.Name
End Sub

Sh05Dekosukeというオブジェクト名のWorksheetオブジェクトを取得し、そのNameプロパティの値をイミディエイト・ウインドウに表示させようという試み。

f:id:akashi_keirin:20190511091532j:plain

ちゃんと、Sh05Dekosukeオブジェクトに相当するWorksheetオブジェクトのNameプロパティが取得できていることがわかる。

おわりに

オブジェクト名を用いたWorksheetオブジェクトへのアクセスは、ブック(プロジェクト)内で閉じた処理には多用しているが、ブック(プロジェクト)間をまたいだ処理で使えなかった。

しかし、事前にオブジェクト名を指定せねばならんにせよ、少しは道が開けたかも知れない。

ちなみに

たとえば、今回のSh01Ahoオブジェクトの場合、親オブジェクトは何なのだろう、と思って調べてみた。

イミディエイト・ウインドウに

?Sh01Aho.pa

まで打ち込むと、

f:id:akashi_keirin:20190511091534j:plain

このように、Parentプロパティが入力候補に出てくる。

期待に胸を高鳴らせつつ、

?Sh01Aho.Parent

と入力して[Enter]!

f:id:akashi_keirin:20190511091537j:plain

なんやねん、それ。

ちなみに、「VBAProject」を参照設定してやると、別ブック(プロジェクト)からでもVBAProject.Sh01Ahoみたいにすれば各シートオブジェクトにアクセスすることはできる模様。しかしながら、同じプロジェクト名でもブックが変われば参照設定は切れてしまう(当り前)ので、あまり使い道はなさそう。

炎上wしたコメント欄への対応

炎上wしたコメント欄への対応

f:id:akashi_keirin:20190511075833p:plain
※この画像はフランスジョークですw

大量のExcelブックと戦う業務があって、そのときに必要なシートの名前を勝手に変える人がちょこちょこいたせいで難儀したので、間に合わせでシート名が改変されたブックを検知するメソッドを作った。

そのことを、ほんの軽~い気持ちで

akashi-keirin.hatenablog.com

コチラに書いたところ、なんとコメント欄が炎上wしてしまった。

軽はずみに物議を醸すような記事を書いてしまって申しわけないw

軽く言いわけ

まず、前回記事は、出勤前に慌てて書いたこともあって、状況の説明が不足していた。あと、誤字もあった。

補足しておく。

置かれていた状況

そもそも、次のような状況だった。

  • 様式ブックは当方で作成したものを配布。
  • いちおう、シートの保護はかけていた。
  • 集めたブックの特定のシートについて、印刷範囲と改ページ位置を調整した上でプリントアウトしたい。
  • プリントアウト対象のシート名は結構ややこしい名前にしているので、「わざわざここを変えるやつはおらんやろ」と思い、ブックの保護まではしていなかった。

およそ、このような状況だった。

必要な処理は、

  • フォルダ内の処理対象ブックを開く。
  • 印刷対象のシートを確定する(シートへの記入状況により、印刷すべきシートの数が変わる)。
  • 印刷対象シートについて、印刷範囲と改ページ位置を調整する(記入内容によっては行が追加されることがあるので、改ページ位置を調整することによって倍率を変更する)
  • 印刷対象シートを順にプリントアウトする
  • ブックを閉じてフォルダ移動する

こんな感じ。

炎上wしたコメント欄への回答

コメント欄に長文は書きにくいので、こちらで回答します。

空腹おやじ (id:Z1000S)さん

難しく考えすぎているような気がするんですが?

いや、むしろ、すごーく安易に考えた結果です。

プリントアウト用マクロ自体、間に合わせでちゃちゃっと書いたようなシロモノで、エラー対応なんて全然していなかったため、シート名が変えられていたときに「インデックスが~」エラーが出るわけです。

そこでまあ、これでいこか、とw

単純にマッチングを見るだけなら、targetBook.WorksheetsとshNamesArrayの2重ループで比較すれば良い

「2重ループ」で総当たりするほどのものでもないと思ったんですよね……。

単一ループで
If targetBook.Worksheets(i).Name <> shNamesArray(i - 1) Then
でチェックすれば、シートの並びの変更もハジケます。

シート名で対象シートを指定する方式にしていたので、この方法は全く考慮に入れませんでした。

リスト1のコードは、ワークシートが追加されていた場合をハジケません

やりたい処理が、上記のとおり〈指定したシートを印刷する〉というものだったので、変なシートが追加されていたとしても問題なし(対象シートの名前が変えられて、新規追加シートに対象シートの名前を付けられたら「ち~んw」でしょうけどw)だと思いました。

jinoji さん

dictionary型に入れておいて、Existsで確認する

すでにFileSystemObjectを使うために参照設定しているので、それもありかも、ですね。Dictionaryをセットするのがちょいめんどくさい? 一緒かw

シート名でなくてシートのクラス名?codename?を分かりやすく変更しておいて、それを使う

CodeNameというものを全く知りませんでした。今度試してみます。ありがとうございました。

id:imihito さん

「シートの存在判定」という観点では、現在の方法、「実際に試してエラーの有無で判定」がベスト

上記のとおり、単純に〈その名前のシートが存在するか〉を判定したかっただけなので、id:imihito さんにそのように言ってもらえると、非常に心強く思います。

Excel側のシート名同一判定と、VBAの文字列比較が同じ結果となる保証が無い

この発想はまるでありませんでした。

ただし、これについては、jinoji さんのコメントに

特に困らない気がするし、そんなことをする利用者は滅多にいない気もする。

とあるように、それほど気にすることでもなかったのかも知れませんね。

それにしても、空腹おやじ (id:Z1000S) さんの実験結果、

aというワークシートがある時に、

? ThisWorkbook.Worksheets("A").Name="A"
False
? ThisWorkbook.Worksheets("A").Name="a"
True

? ThisWorkbook.Worksheets("a").Name="A"
False
? ThisWorkbook.Worksheets("a").Name="a"
True

となりました。

は、非常にキモチワルイ挙動ですね……。

ExcelVBAer (id:x1xy2xyz3)さん

自分なら CodeName で判定しますかね。

シート名が変更される可能性が高い事が分かってるというのであれば、CodeName の方が無難な気がします。

同一ブック内で閉じた処理なら、シートの指定は全てオブジェクト名でやるようになっていましたが、ブックをまたがる処理のときには従来どおりインデックス名でアクセスしていました。今回、皆様のおかげでCodeNameというものを知りましたので、積極的に使っていこうと思いました。

おわりに

みなさん、ありがとうございました!!!!!!!!

もっと燃やせ!

シート名の変更を検知する(Excel)

シート名の変更を検知する(Excel)

各所から集めた大量のExcelブックを処理するとき、配布した様式ブックに保護をかけ忘れると、それはもう、好き放題にシート名をいじくられるw

マクロで処理しようにも、シート名とかシートの順序を変えられると、ちょっと対応がむつかしいので、シート名が本来のあるべき姿から変わり果ててしまったブックを検出するメソッドを作ってみた。

コーディング

Worksheetsコレクションのインデックスに、ブックに存在しないシート名を指定すると、実行時エラーが出るので、その性質を利用した。

リスト1 標準モジュール
Public Function hasAppropriateSheetNames( _
           ByVal targetBook As Workbook, _
           ByRef shNamesArray() As String) As Boolean  '……(1)'
  On Error GoTo Finalizer  '……(2)'
  hasAppropriateSheetNames = False  '……(3)'
  Dim i As Long
  Dim stalkingHorse As String
  For i = LBound(shNamesArray) To UBound(shNamesArray)  '……(4)'
    stalkingHorse = targetBook.Worksheets(shNamesArray(i)).Name
  Next
  hasAppropriateSheetNames = True  '……(5)'
Finalizer:
  Call Err.Clear
End Function

(1)の

Public Function hasAppropriateSheetNames( _
           ByVal targetBook As Workbook, _
           ByRef shNamesArray() As String) As Boolean

で引数設定。

今回は、ブックオブジェクトと適切なシート名を格納したString型配列を受け取るようにした。返り値はBoolean型。適切なシート名のシートが完備されていればTrueを返す。

(2)の

On Error GoTo Finalizer

で、エラーが出たら、一番下のラベルにワープするようにした。

必要ないけど、(3)の

hasAppropriateSheetNames = False

で初期値を明示的にFalseにしているので、エラーが出た瞬間、Finalizer:ラベルにワープしてそのまま抜ける。つまり、存在しないシート名にぶつかると、Falseが変えるしくみ。

(4)からの3行

For i = LBound(shNamesArray) To UBound(shNamesArray)  '……(4)'
  stalkingHorse = targetBook.Worksheets(shNamesArray(i)).Name
Next

がメイン。

引数として受け取ったシート名を順にWorksheetsコレクションのインデックスに指定し、取得したWorksheetオブジェクトのNameプロパティの値(要するにシート名の文字列)を変数stalkingHorseにぶち込む。変数stalkingHorseは、ただNameプロパティの返り値を受け取るだけ! まさにStalking Horse!!!!!!!!

存在しないシート名だったら、実行時エラーが出るので、Finalizer:ラベルまで飛び、エラーをクリアしてFalseを返す。

無事(4)のForループを抜けたということは、配列shNamesArray内のシート名は全て存在したということになるので、(5)の

hasAppropriateSheetNames = True

で返り値をTrueにする。

使ってみる

同じフォルダ内に、Test.xlsxというブックを置き、シート名を

f:id:akashi_keirin:20190509073949j:plain

このように設定しておく。

で、次のコードを実行。

スト2 標準モジュール
Public Sub test01()
  Dim shNamesArray() As String
  shNamesArray = Split("アホ ボケ カス ラッパ 空気")
  Dim targetBook As Workbook
  Set targetBook = Workbooks.Open(ThisWorkbook.Path & "\Test.xlsx")
  Debug.Print hasAppropriateSheetNames(targetBook, shNamesArray)
  shNamesArray = Split("アホ ボケ カス ラッパ デコスケ")
  Debug.Print hasAppropriateSheetNames(targetBook, shNamesArray)
  Call targetBook.Close(False)
End Sub

Splitの返り値をString型の配列にぶち込むことができる、というのは初めて知ったかもしれない。

hasAppropriateSheetNamesを2回呼んでいるが、1回目は「空気」というTest.xlsxには存在しないシート名を配列にぶち込んでいる。

2回目は、全てTest.xlsxに存在するシート名を配列にぶち込んだ。

実行結果

f:id:akashi_keirin:20190509073952j:plain

意図どおり。

おわりに

エラーを判定材料に使っているというのがイマイチかも。

他にどんなやり方があるかなあ。

メール作成クラス群は今……

メール作成クラス群は今……

とりあえず、一段落したので、現状をご報告。

結果的に、

  • IMailCreatableインターフェース
  • IMailSendableインターフェース
  • LotusNotesAppクラス
  • ThunderbirdAppクラス
  • OutlookAppクラス
  • Recipientクラス
  • Senderクラス
  • ErrorObjectクラス

という実に八つものクラスモジュールを用いる一大プロジェクトになってしまった。

いよいよ本格的にアドイン化を検討せねばならん。

各クラスの役割

簡単に各クラスの役割を紹介しておこう。

IMailCreatableインターフェース

こいつをImplementsしたクラスは、メール作成可能。LotusNotesAppThunderbirdAppOutlookAppの三つにImplementsしているので、こいつらのインスタンスIMailCreatable型変数に突っ込んでやると、createMailメソッドを実行すれば、各クラスのメール作成メソッドを実行してくれる。

IMailSendableインターフェース

こいつをImplementsしたクラスは、メール送信が可能。LotusNotesAppOutlookAppの二つにImplementsしているので、こいつらのインスタンスIMailCreatable型変数に突っ込んでやると、sendMailメソッドを実行すれば、各クラスのメール送信メソッドを実行してくれる。ThunderbirdAppクラスにはImplementsしていないので、IMailCreatable型変数に突っ込むことはできない(はず。実験はしていない。めんどくさいので。)。

LotusNotesAppクラス

Lotus Notesを操るためのクラス。メール作成と送信ができる。

ThunderbirdAppクラス

Thunderbirdを操るためのクラス。メール作成のみ可能。

OutlookAppクラス

Outlookを操るためのくらす。メール作成と送信ができる。

Recipientクラス

メール送信先のデータを格納するのに使う。

Senderクラス

メール発信者のデータを格納するのに使う。実質Lotus Notesのためにしか使わない。Lotus Notesの既定の署名をセットする方法がわかったら要らなくなるかも。

ErrorObjectクラス

メール作成、送信メソッドの返り値に用いる。メソッド実行中に発生したエラー情報を持ち帰ってくる、というイメージ。こんな使い方が必要なのかどうかはよくわからない。

ソースコード

めちゃくちゃ長くなるけど、ぶちまけておく。

IMailCreatableインターフェース
Option Explicit

Public Function createMail( _
            ByVal targetRecipient As Recipient, _
            ByVal currentSender As Sender, _
            ByVal mailSubject As String, _
            ByRef mailBody() As String, _
            ByRef attFilePath() As String, _
   Optional ByVal allowRetReceipt As Boolean = False) As ErrorObject
  
End Function
IMailSendableインターフェース
Option Explicit

Public Function sendMail() As ErrorObject

End Function
LotusNotesAppクラス
Option Explicit

Implements IMailCreatable
Implements IMailSendable

'Constants'
Private Const EMBED_ATTACHMENT As Long = 1454
Private Const MAIN_FONTSIZE As Double = 12
Private Const SUB_FONTSIZE As Double = 10

Private Const FAILED_TO_ATTACH As String = "ファイル添付失敗"
Private Const NOTES_NOT_AVAILABLE As String = "Lotus Notes使用不可"
Private Const FAILED_TO_CREATE As String = "LotusNotesメール作成失敗"
Private Const FAILED_TO_SEND As String = "LotusNotesメール送信失敗"

Private notesSession As Object
Private notesUIWorkspace As Object
Private notesDatabase As Object
Private notesDocument As Object
Private notesRichTextItem As Object
Private notesRichTextStyle As Object
Private notesEmbeddedObject As Object
Private notesUIDocument As Object

Private errorSource As String

Private Sub Class_Initialize()

End Sub

Private Sub Class_Terminate()
  Set notesSession = Nothing
  Set notesUIWorkspace = Nothing
  Set notesDatabase = Nothing
  Set notesDocument = Nothing
  Set notesRichTextItem = Nothing
  Set notesRichTextStyle = Nothing
  Set notesEmbeddedObject = Nothing
  Set notesUIDocument = Nothing
End Sub

Public Function IMailCreatable_createMail( _
            ByVal targetRecipient As Recipient, _
            ByVal currentSender As Sender, _
            ByVal mailSubject As String, _
            ByRef mailBody() As String, _
            ByRef attFilePath() As String, _
   Optional ByVal allowRetReceipt As Boolean = False) As ErrorObject
  On Error Resume Next
  Call Err.Clear
  'メール作成準備'
  Set notesSession = CreateObject("Notes.NotesSession")
  Set notesUIWorkspace = CreateObject("Notes.NotesUIWorkspace")
  Set notesDatabase = notesSession.getDatabase("", "")
  Call notesDatabase.openMail
  If Err.Number > 0 Then errorSource = NOTES_NOT_AVAILABLE: GoTo ErrorHandler
  
  '受信確認設定準備'
  Dim retReceipt As String
  retReceipt = ""
  If allowRetReceipt Then retReceipt = "1"
  'データベースに文書を作成して、新規文書を表す NotesDocument オブジェクトを返す。'
  '新規文書をディスクに保存するには、Save を呼び出す必要がある。'
  Set notesDocument = notesDatabase.createDocument()
  '文書に題名・宛先・受信確認有無を設定'
  With notesDocument
    .Subject = mailSubject
    .SendTo = targetRecipient.MailAddress
    If targetRecipient.CC <> "" Then .CopyTo = targetRecipient.CC
    If targetRecipient.BCC <> "" Then .BlindCopyTo = targetRecipient.BCC
    .ReturnReceipt = retReceipt
  End With
  '文書にリッチテキストアイテムを作成する'
  Set notesRichTextItem = notesDocument.createRichTextItem("BODY")
  Set notesRichTextStyle = notesSession.createRichTextStyle("BODY")
  notesRichTextStyle.FontSize = MAIN_FONTSIZE
  'メール本文の左肩部分を作成する'
  Set notesRichTextItem = getHeaderAppendedRichTextItem(notesRichTextItem, _
                                                        targetRecipient)
  'メール本文の本体部分を作成する'
  Set notesRichTextItem = getMailBodyAppendedRichTextItem(notesRichTextItem, _
                                                          mailBody())
  '本文以外のフォントサイズを設定'
  notesRichTextStyle.FontSize = SUB_FONTSIZE
  Call notesRichTextItem.appendStyle(notesRichTextStyle)
  If Err.Number > 0 Then errorSource = FAILED_TO_CREATE: GoTo ErrorHandler
  '添付ファイルを追加する'
  Set notesRichTextItem = getFileAttachedRichTextItem(notesRichTextItem, _
                                                      attFilePath())
  If Err.Number > 0 Then errorSource = FAILED_TO_ATTACH: GoTo ErrorHandler
  '署名を附加する'
  Set notesRichTextItem = getSignAppendedRichTextItem(notesRichTextItem, _
                                                      currentSender)
  'メールを保存する'
  Call notesDocument.Save(False, False)
  'メールを編集状態にする'
  Set notesUIDocument = notesUIWorkspace.EditDocument(True, notesDocument, False)
  If Err.Number > 0 Then errorSource = FAILED_TO_CREATE: GoTo ErrorHandler
ErrorHandler:
  Dim ret As ErrorObject
  Set ret = ErrorObject.getInstance(number__:=Err.Number, _
                                    description__:=Err.Description)
  ret.Source = errorSource
  Set IMailCreatable_createMail = ret
  Set ret = Nothing
  Call Err.Clear
End Function

Private Function getHeaderAppendedRichTextItem( _
          ByVal targetNotesRichTextItem As Object, _
          ByVal targetRecipient As Recipient) As Object
'メール本文の左肩部分を作成して返す'
  Dim ret As Object
  Set ret = targetNotesRichTextItem
  With targetRecipient
    Call ret.appendStyle(notesRichTextStyle)
    Call ret.appendText(.CompanyName)
    Call ret.addNewLine(1)
    Call ret.appendText(" " & .JobTitle & " " & .Name & " 様")
    Call ret.addNewLine(3)
  End With
  Set getHeaderAppendedRichTextItem = ret
End Function

Private Function getMailBodyAppendedRichTextItem( _
                   ByVal targetNotesRichTextItem As Object, _
                   ByRef mailBody() As String) As Object
'メール本文の本体部分を作成して返す'
  Dim ret As Object
  Set ret = targetNotesRichTextItem
  Dim i As Long
  For i = LBound(mailBody) To UBound(mailBody)
    If mailBody(i) = "" Then GoTo Continue
    Call ret.appendText(mailBody(i))
    Call ret.addNewLine(2)
Continue:
  Next
  Call ret.addNewLine(2)
  Set getMailBodyAppendedRichTextItem = ret
End Function

Private Function getFileAttachedRichTextItem( _
                   ByVal targetNotesRichTextItem As Object, _
                   ByRef attFilePath() As String) As Object
'添付ファイルを添付する'
  Dim ret As Object
  Set ret = targetNotesRichTextItem
  Dim tmp As Long
  tmp = UBound(attFilePath)
  If tmp = 0 And attFilePath(tmp) = "" Then GoTo Finalizer
  Dim i As Long
  For i = LBound(attFilePath) To UBound(attFilePath)
    If attFilePath(i) = "" Then GoTo Continue
    Set notesEmbeddedObject = ret.EmbedObject(EMBED_ATTACHMENT, _
                                              "", _
                                              attFilePath(i))
    Call ret.addTab(1)
    Call ret.addNewLine(2)
Continue:
  Next
Finalizer:
  Set getFileAttachedRichTextItem = ret
End Function

Private Function getSignAppendedRichTextItem( _
                   ByVal targetNotesRichTextItem As Object, _
                   ByVal currentSender As Sender) As Object
'送信者の署名を附加する'
  Dim ret As Object
  Set ret = targetNotesRichTextItem
  With currentSender
    Call ret.addNewLine(3)
    Call ret.appendText("===============================")
    Call ret.addNewLine(1)
    Call ret.appendText(.CompanyName)
    Call ret.addNewLine(1)
    Call ret.appendText(" " & .DivisionName)
    Call ret.addNewLine(1)
    Call ret.appendText("  " & .JobTitle & "  " & .Name)
    Call ret.addNewLine(1)
    Call ret.appendText(.ZipCode)
    Call ret.addNewLine(1)
    Call ret.appendText(" " & .Address)
    Call ret.addNewLine(1)
    Call ret.appendText(" TEL   " & .PhoneNumber)
    Call ret.addNewLine(1)
    Call ret.appendText(" FAX   " & .FaxNumber)
    Call ret.addNewLine(1)
    Call ret.appendText(" Email " & .MailAddress)
    Call ret.addNewLine(1)
    Call ret.appendText("===============================")
    Call ret.addNewLine(1)
  End With
  Set getSignAppendedRichTextItem = ret
End Function

Public Function IMailSendable_sendMail() As ErrorObject
  On Error Resume Next
  Call CallByName(notesUIDocument, "Send", VbMethod, False)
  Call notesUIDocument.Save  'ここで保存しておくと、閉じるときのメッセージ表示を防げる'
  Call notesUIDocument.Close(True)
  If Err.Number > 0 Then errorSource = FAILED_TO_SEND
ErrorHandler:
  Dim ret As ErrorObject
  Set ret = ErrorObject.getInstance(number__:=Err.Number, _
                                    description__:=Err.Description)
  ret.Source = errorSource
  Set IMailSendable_sendMail = ret
  Set ret = Nothing
  Call Err.Clear
End Function
ThunderbirdAppクラス
Option Explicit

Implements IMailCreatable

'Constants'
Private Const TB_NOT_AVAILABLE As String = "Thunderbird実行不可"
Private Const FAILED_TO_CREATE As String = "Thunderbirdメール作成失敗"

'Module Level Variables'
Private exePath As String
Private isAvailable As Boolean

Private errorSource As String

Public Sub init(ByVal ThunderbirdExePath As String)
  isAvailable = False
  exePath = ThunderbirdExePath
  Dim fsObj As New FileSystemObject
  If fsObj.FileExists(exePath) Then isAvailable = True
End Sub

Public Function IMailCreatable_createMail( _
            ByVal targetRecipient As Recipient, _
            ByVal currentSender As Sender, _
            ByVal mailSubject As String, _
            ByRef mailBody() As String, _
            ByRef attFilePath() As String, _
   Optional ByVal allowReturnReceipt As Boolean = False) As ErrorObject
  If Not isAvailable Then errorSource = TB_NOT_AVAILABLE: GoTo ErrorHandler
  On Error Resume Next
  Call Err.Clear
  'Shell関数の引数を作る'
  Dim thunderbirdPath As String
  thunderbirdPath = exePath & " -compose "
  '件名をセット'
  If mailSubject = "" Then mailSubject = "無題"
  '左肩部分をセット'
  Dim bodyString As String
  With targetRecipient
    bodyString = .CompanyName & "%0A" & " " & _
                 .JobTitle & " " & _
                 .Name & " 様"
  End With
  '左肩部分の下に2行文空行をセット'
  bodyString = bodyString & "%0A" & "%0A" & "%0A"
  '本文をbodyStringに連結していく'
  Dim i As Long
  For i = LBound(mailBody) To UBound(mailBody)
    If mailBody(i) <> "" Then _
      bodyString = bodyString & mailBody(i) & "%0A" & "%0A"
  Next
  bodyString = Replace(bodyString, ",", ",")
  bodyString = Replace(bodyString, "vblf", "%0A")
  '添付ファイルフルパスをつなぐ'
  Dim attFilesString As String
  For i = LBound(attFilePath) To UBound(attFilePath)
    If attFilePath(i) <> "" Then _
      attFilesString = attFilesString & attFilePath(i) & ","
  Next
  '右端の「,」を除去する'
  If Right(attFilesString, 1) = "," Then
    attFilesString = Left(attFilesString, Len(attFilesString) - 1)
  End If
  '両端を「'」で囲む''
  attFilesString = "'" & attFilesString & "'"
  'メールを作成する'
  With targetRecipient
    Call Shell(thunderbirdPath & _
               "to=" & Replace(.MailAddress, ",", ";") & "," & _
               "cc=" & Replace(.CC, ",", ";") & "," & _
               "bcc=" & Replace(.BCC, ",", ";") & "," & _
               "subject=""" & mailSubject & """," & _
               "body=""" & bodyString & """," & _
               "attachment=""" & attFilesString & """")
  End With
  If Err.Number > 0 Then errorSource = FAILED_TO_CREATE: GoTo ErrorHandler
ErrorHandler:
  Dim ret As ErrorObject
  Set ret = ErrorObject.getInstance(number__:=Err.Number, _
                                    description__:=Err.Description)
  ret.Source = errorSource
  Set IMailCreatable_createMail = ret
  Set ret = Nothing
  Call Err.Clear
End Function
OutlookAppクラス
Option Explicit

Implements IMailCreatable
Implements IMailSendable

'Constants'
Private Const OUTLOOK_NOT_AVAILABLE As String = "Outlook使用不可"
Private Const FAILED_TO_CREATE As String = "Outlookメール作成失敗"
Private Const FAILED_TO_SEND As String = "Outlookメール送信失敗"

'Module Level Variables'
Private olApp As Outlook.Application
Private isAvailable As Boolean
Private targetMailItem As MailItem

Private errorSource As String

Private Sub Class_Initialize()
  On Error Resume Next
  Call Err.Clear
  isAvailable = False
  Set olApp = GetObject(, "Outlook.Application")
  Call Err.Clear
  If olApp Is Nothing Then
    Set olApp = getCurrentOutlook
  End If
  Err.Clear
  If olApp Is Nothing Then Exit Sub
  isAvailable = True
End Sub

Public Function IMailCreatable_createMail( _
            ByVal targetRecipient As Recipient, _
            ByVal currentSender As Sender, _
            ByVal mailSubject As String, _
            ByRef mailBody() As String, _
            ByRef attFilePath() As String, _
   Optional ByVal allowRetReceipt As Boolean = False) As ErrorObject
  If Not isAvailable Then errorSource = OUTLOOK_NOT_AVAILABLE: GoTo ErrorHandler
  On Error Resume Next
  Call Err.Clear
  '本文文字列の作成'
  '左肩部分の作成'
  Dim leftHeaderString As String
  With targetRecipient
    leftHeaderString = .CompanyName & vbCrLf & " " & _
                       .JobTitle & " " & _
                       .Name & " 様" & _
                       vbCrLf & vbCrLf & vbCrLf
  End With
  '本文をbodyStringに連結していく'
  Dim bodyString As String
  Dim i As Long
  For i = LBound(mailBody) To UBound(mailBody)
    If mailBody(i) <> "" Then _
      bodyString = bodyString & mailBody(i) & vbCrLf & vbCrLf
  Next
  Set targetMailItem = olApp.CreateItem(olMailItem)
  With targetMailItem
    'デフォルトの署名文字列を取得するために一旦RichText形式にする'
    .BodyFormat = olFormatRichText
    Call .Display
    'この時点ではBodyプロパティには署名文字列しか入っていないので、'
    '署名文字列を変数に入れる。'
    Dim senderSign As String
    senderSign = .Body
    'ここでHTML形式に変える'
    .BodyFormat = olFormatHTML
    .To = Replace(targetRecipient.MailAddress, ",", ";")
    .CC = Replace(targetRecipient.CC, ",", ";")
    .BCC = Replace(targetRecipient.BCC, ",", ";")
    .Subject = mailSubject
    '左肩、本文、署名の順にBodyプロパティに書き込む'
    .Body = leftHeaderString & _
            bodyString & vbCrLf & vbCrLf & _
            senderSign
    If Err.Number > 0 Then errorSource = FAILED_TO_CREATE: GoTo ErrorHandler
    '添付ファイルの設定'
    For i = LBound(attFilePath) To UBound(attFilePath)
      If attFilePath(i) <> "" Then _
        Call .Attachments.Add(attFilePath(i))
    Next
    '受信確認設定'
    If allowRetReceipt Then _
      .ReadReceiptRequested = True
  End With
  If Err.Number > 0 Then errorSource = FAILED_TO_CREATE: GoTo ErrorHandler
ErrorHandler:
  Dim ret As ErrorObject
  Set ret = ErrorObject.getInstance(number__:=Err.Number, _
                                    description__:=Err.Description)
  ret.Source = errorSource
  Set IMailCreatable_createMail = ret
  Set ret = Nothing
  Call Err.Clear
End Function

Private Function getCurrentOutlook() As Outlook.Application
  Dim targetOutlook As New Outlook.Application
  Dim currentNameSpace As Outlook.Namespace
  Set currentNameSpace = targetOutlook.GetNamespace("MAPI")
  Dim targetFolder As Outlook.Folder
  If targetOutlook.Explorers.Count > 0 Then
    Set targetFolder = _
          targetOutlook.Explorers.Item(1).CurrentFolder
  Else
    Set targetFolder = _
          currentNameSpace.GetDefaultFolder(olFolderInbox) 
          '既定のフォルダー olFolderInbox=6 指定'
  End If
  Call targetFolder.Display
  Set getCurrentOutlook = targetOutlook
End Function

Public Function IMailSendable_sendMail() As ErrorObject
  Call targetMailItem.Send
  If Err.Number > 0 Then errorSource = FAILED_TO_SEND
ErrorHandler:
  Dim ret As ErrorObject
  Set ret = ErrorObject.getInstance(number__:=Err.Number, _
                                    description__:=Err.Description)
  ret.Source = errorSource
  Set IMailSendable_sendMail = ret
  Set ret = Nothing
  Call Err.Clear
End Function
Recipientクラス
Option Explicit

Private mailAddress_ As String
Private companyName_ As String
Private jobTitle_ As String
Private name_ As String
Private CC_ As String
Private BCC_ As String
Private isInitialized_ As Boolean

Public Property Get MailAddress() As String
  MailAddress = mailAddress_
End Property
Public Property Get CompanyName() As String
  CompanyName = companyName_
End Property
Public Property Get JobTitle() As String
  JobTitle = jobTitle_
End Property
Public Property Get Name() As String
  Name = name_
End Property
Public Property Get CC() As String
  CC = CC_
End Property
Public Property Get BCC() As String
  BCC = BCC_
End Property
Public Property Get IsInitialized() As Boolean
  IsInitialized = isInitialized_
End Property

Public Sub init(ByVal mailAddress__ As String, _
                ByVal companyName__ As String, _
                ByVal jobTitle__ As String, _
                ByVal name__ As String, _
       Optional ByVal CC As String = "", _
       Optional ByVal BCC As String = "")
  mailAddress_ = mailAddress__
  companyName_ = companyName__
  jobTitle_ = jobTitle__
  name_ = name__
  CC_ = CC
  BCC_ = BCC
  isInitialized_ = True
End Sub
Senderクラス
Option Explicit

Private companyName_ As String
Private divisionName_ As String
Private jobTitle_ As String
Private name_ As String
Private zipCode_ As String
Private address_ As String
Private phoneNumber_ As String
Private faxNumber_ As String
Private mailAddress_ As String

Public Property Get CompanyName() As String
  CompanyName = companyName_
End Property
Public Property Get DivisionName() As String
  DivisionName = divisionName_
End Property
Public Property Get JobTitle() As String
  JobTitle = jobTitle_
End Property
Public Property Get Name() As String
  Name = name_
End Property
Public Property Get ZipCode() As String
  ZipCode = zipCode_
End Property
Public Property Get Address() As String
  Address = address_
End Property
Public Property Get PhoneNumber() As String
  PhoneNumber = phoneNumber_
End Property
Public Property Get FaxNumber() As String
  FaxNumber = faxNumber_
End Property
Public Property Get MailAddress() As String
  MailAddress = mailAddress_
End Property

Public Sub init(ByVal companyName__ As String, _
                ByVal divisionName__ As String, _
                ByVal jobTitle__ As String, _
                ByVal name__ As String, _
                ByVal zipCode__ As String, _
                ByVal address__ As String, _
                ByVal phoneNumber__ As String, _
                ByVal faxNumber__ As String, _
                ByVal mailAddress__ As String)
  companyName_ = companyName__
  divisionName_ = divisionName__
  jobTitle_ = jobTitle__
  name_ = name__
  zipCode_ = zipCode__
  address_ = address__
  phoneNumber_ = phoneNumber__
  faxNumber_ = faxNumber__
  mailAddress_ = mailAddress__
End Sub
ErrorObjectクラス
Option Explicit

'///Attribute VB_PredeclaredId = True///'

Private number_ As Long
Private description_ As String
Private lastDllError_ As Long
Private source_ As String

Public Property Get Number() As Long
  Number = number_
End Property
Public Property Let Number(ByVal value_ As Long)
  number_ = value_
End Property

Public Property Get Description() As String
  Description = description_
End Property
Public Property Let Description(ByVal value_ As String)
  description_ = value_
End Property

Public Property Get LastDllError() As Long
  LastDllError = lastDllError_
End Property
Public Property Let LastDllError(ByVal value_ As Long)
  lastDllError_ = value_
End Property

Public Property Get Source() As String
  Source = source_
End Property
Public Property Let Source(ByVal value_ As String)
  source_ = value_
End Property

Public Sub clearError()
  number_ = 0
  description_ = ""
  lastDllError_ = 0
  source_ = ""
  Call Err.Clear
End Sub
Public Sub raiseError( _
             Optional ByVal number__ As Long, _
             Optional ByVal source__ As Long, _
             Optional ByVal description__ As String)
  If number__ > 0 Then number_ = number__
  If source__ > 0 Then source_ = source__
  If description__ <> "" Then description_ = description__
  If number_ = 0 Then Exit Sub
  Call Err.Raise(number_, source_, description_)
End Sub

Public Function getInstance( _
                  ByVal number__ As Long, _
         Optional ByVal description__ As String, _
         Optional ByVal source__ As String, _
         Optional ByVal lastDllError__ As Long) As ErrorObject
  Dim ret As New ErrorObject
  ret.Number = number__
  ret.Description = description__
  ret.Source = source__
  ret.LastDllError = lastDllError__
  Set getInstance = ret
End Function

おっそろしく長いwww

使い方

使い方の一例を示す。

標準モジュールに次のコードを書く。

Private Enum MailApp
  maLotusNotes
  maThunderbird
  maOutlook
End Enum

Private mailCreator As IMailCreatable
Private mailSender As IMailSendable
Private notesApp As LotusNotesApp
Private tbApp As ThunderBirdApp
Private olApp As OutlookApp

Public Sub test()
  Call createMailCaller(maLotusNotes)
  Call createMailCaller(maOutlook, True)
End Sub

Private Sub createMailCaller(ByVal targetApp As MailApp, _
                    Optional ByVal isToSend As Boolean = False)
  '送信先情報をセット'
  Dim targetRecipient As Recipient
  Set targetRecipient = New Recipient
  Call targetRecipient.init("hoge@foobar.XXXX.com", _
                            "有限会社 大企業", _
                            "取締役社長", _
                            "一堂 零", _
                            "fuga@foobar.XXXX.com", _
                            "hage@foobar.XXXX.com")
  '送信者情報をセット'
  Dim currentSender As Sender
  Set currentSender = New Sender
  Call currentSender.init("財団法人", _
                          "日本相撲協会", _
                          "理事長", _
                          "保志 信芳", _
                          "130-0015", _
                          "東京都墨田区両国横網1-1-1", _
                          "03-XXXX-XXXX", _
                          "03-XXXX-XXXX", _
                          "toukaioozumou@sagami.com")
  'メール本文情報をセット'
  Dim mailBody(3) As String
  mailBody(0) = "ち~んw"
  mailBody(1) = "( ´,_ゝ`)プッ"
  mailBody(2) = "(゚∀゚)アヒャ"
  mailBody(3) = "( ´_ゝ`)フーン"
  '添付ファイル情報をセット'
  Dim attFilePaths(0) As String
  attFilePaths(0) = "X:\アホの坂田.jpg"
  '指定のメールアプリに応じてインスタンス化'
  Select Case targetApp
    Case maLotusNotes
      Set mailCreator = New LotusNotesApp
    Case maThunderbird
      Dim tbApp As New ThunderBirdApp
      Call tbApp.init("C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe")
      Set mailCreator = tbApp
    Case maOutlook
      Set mailCreator = New OutlookApp
  End Select
  'メール作成'
  Dim result As ErrorObject
  Set result = mailCreator.createMail( _
                              targetRecipient, _
                              currentSender, _
                              "ち~んw", _
                              mailBody, _
                              attFilePaths, _
                              False)
  If result.Number > 0 Then GoTo ErrorHandler
  'isToSendがFalseなら抜ける'
  If Not isToSend Then Exit Sub
  'isToSendがTrueならメール送信'
  'mailSender型変数に代入'
  Set mailSender = mailCreator
  Set result = mailSender.sendMail
  If result.Number > 0 Then GoTo ErrorHandler
  Exit Sub
ErrorHandler:
  'エラーが生じていたら、エラーに応じた文字列を出力'
  With result
    Debug.Print .Number & ":" & .Description & " by " & .Source
  End With
End Sub

本来、Private createMailCallerメソッド内部の諸データは、引数で持たせるべきだけれど、めんどくさいのでジカ書き。

許してちょ。

使ってみる

testを実行してみる。

まず、

Call createMailCaller(maLotusNotes)

を実行したところで、

f:id:akashi_keirin:20190503102752j:plain

こうなる。

家のPCにはLotus Notesが入っていないので、当然こうなる。

次に、

Call createMailCaller(maOutlook, True)

を実行して、メールが送られた。Outlookの送信履歴を見ると、

f:id:akashi_keirin:20190503102755j:plain

ちゃんとメールが送信されている。

当然、デタラメなメールアドレスなので、MAILER-DAEMONが返ってきましたけどw

おわりに

ここまで読んでくれた人はいるのだろうか……。

Rahmenクラスの修正

Rahmenクラスの修正

前回

akashi-keirin.hatenablog.com

Rahmenクラスを修正した。

生まれ変わったRahmenクラス

クラスモジュール Rahmen
Option Explicit

'///Attribute VB_PredeclaredId = True///'

Public Enum NoodleSolidity
  nsYugeTooshi
  nsKonaOtoshi
  nsHarigane
  nsBariKata
  nsKata
  nsFutsuu
  nsYawa
  nsZundare
End Enum

Private count_ As Long

Private solidity_ As String
Private isInstantiating_ As Boolean

Public Property Get Solidity() As String
  Solidity = solidity_
End Property

Public Property Let Count(ByVal value_ As Long)'……(1)'
  count_ = value_
End Property
Public Property Get Count() As Long
  Count = count_
End Property

Public Property Get Kaedama() As String
  Kaedama = CStr(count_) & "玉目"
End Property

Public Property Let IsInstantiating( _
                      ByVal value_ As Boolean)'……(2)'
  isInstantiating_ = value_
End Property

Private Sub Class_Initialize()
  solidity_ = "ふつう"
End Sub

Public Sub setSolidity(ByVal solidityArg As NoodleSolidity)
  solidity_ = getSolidityString(solidityArg)
End Sub

Private Function getSolidityString( _
             ByVal arg As NoodleSolidity) As String
  Dim ret As String
  Select Case arg
    Case nsYugeTooshi: ret = "湯気とおし"
    Case nsKonaOtoshi: ret = "粉落とし"
    Case nsHarigane: ret = "ハリガネ"
    Case nsBariKata: ret = "バリカタ"
    Case nsKata: ret = "カタ"
    Case nsFutsuu: ret = "ふつう"
    Case nsYawa: ret = "やわ"
    Case nsZundare: ret = "ずんだれ"
    Case Else: ret = "ち~んw"
  End Select
  getSolidityString = ret
  If Not isInstantiating_ Then _
    count_ = Rahmen.Count + 1: Rahmen.Count = count__'……(3)'
End Function

Public Function getInstance( _
            ByVal solidity__ As NoodleSolidity) As Rahmen
  Dim ret As New Rahmen
  ret.IsInstantiating = True'……(4)'
  Call ret.setSolidity(solidity__)
  count_ = Rahmen.Count + 1
  ret.Count = count_
  Set getInstance = ret
  ret.IsInstantiating = False
End Function

変更点が結構ある。

Countプロパティ

まずは、(1)の

Public Property Let Count(ByVal value_ As Long)
  count_ = value_
End Property
Public Property Get Count() As Long
  Count = count_
End Property

CountプロパティがRead/Writeになってしまった。もはやPublicにしようぜ、と言いたくなるレベル。

結局、Rahmenはあくまでインスタンスであり、インスタンス間で値をやりとりするにはこうするほかないのだ。「クラス変数」といっても、所詮「クラス変数っぽい」ものに過ぎない、ということ。

IsInstantiatingプロパティ

次に、IsInstantiatingプロパティ。

これは、getInstance実行中かどうかを判定するためのもの。

〈麺のかたさ〉を設定するgetSolidityStringメソッドが呼ばれる状況は、二通りある。getInstanceメソッドを実行したときと、直接setSolidityメソッドが呼ばれた場合の二通り。

Rahmen.getInstanceメソッドのときは、既定のインスタンスRahmenが持っているcount_の値を、メソッド内で直接インスタンスret)のCountプロパティを通じてインスタンスret)内部の変数Countcount_にセットすることができる。(あー、ややこしい!)

しかし、Rahmen.getInstanceによって生み出されたインスタンスsetSolidityを実行した場合、既定のインスタンスRahmenとは縁が切れてしまっているので、既定のインスタンスRahmenが持っているcount_の値をインスタンスに渡す処理が要る。(ホンマにややこしい! 書いていてわけわかんなくなる!)

そこで、Rahmen.getInstance実行中は、新たに生み出されたインスタンスIsInstantiatingプロパティをTrueにしておいて、getSolidityStringメソッド内の(3)

count_ = Rahmen.Count + 1: Rahmen.Count = count_

が実行されないようにしておく。

逆に、新たに生み出されたインスタンスsetSolidityメソッド実行時には、インスタンスIsInstantiatingプロパティはFalseなので、

count_ = Rahmen.Count + 1: Rahmen.Count = count_

が実行され、新たに生み出されたインスタンス側のcount_の値をインクリメントするとともに、既定のインスタンスRahmenCountプロパティもインクリメントされることになる。

使ってみる

次のコードで実験。

リスト1 標準モジュール
Public Sub disposable01()
  Dim rahmen1 As Rahmen
  Set rahmen1 = Rahmen.getInstance(nsKonaOtoshi)
  Dim rahmen2 As Rahmen
  Set rahmen2 = Rahmen.getInstance(nsBariKata)
  Dim rahmen3 As Rahmen
  Set rahmen3 = Rahmen.getInstance(nsZundare)
  Call printData(rahmen1)
  Call printData(rahmen2)
  Call printData(rahmen3)
  Debug.Print Rahmen.Kaedama
  Call rahmen3.setSolidity(nsHarigane)  '……(4)'
  Call printData(rahmen3)
  Call rahmen2.setSolidity(nsYawa)  '……(5)'
  Call printData(rahmen2)
  Debug.Print String(40, "=")
End Sub

Private Sub printData(ByVal targetRahmen As Rahmen)
  With targetRahmen
    Debug.Print "替え玉:" & .Kaedama; _
                "/麺のかたさ:" & .Solidity
  End With
End Sub

前回のリスト1に加え、(4)の

Call rahmen3.setSolidity(nsHarigane)
Call printData(rahmen3)

で、インスタンスrahmen3で、新たに「ハリガネ」で替え玉を注文し、さらに(5)の

Call rahmen2.setSolidity(nsYawa)
Call printData(rahmen2)

で、インスタンスrahmen2で、新たに「やわ」で替え玉を注文した。

実行結果

一回目。

f:id:akashi_keirin:20190503001253j:plain

二回目。

f:id:akashi_keirin:20190503001255j:plain

ちゃんと通しの替え玉数が表示された。

おわりに

しかしながら、Countプロパティに加え、IsInstantiatingプロパティまで外部から変更可能になってしまった。

所詮は擬似、このあたりが限界なのだろうか……。

追記

このシリーズは続きません。もうやめます。

クラス変数っぽいものを実現してみる

 

クラス変数っぽいものを実現してみる

Attribute VB_PredeclaredIdTrueにしたクラスモジュールでちょっと実験をしてみた。

実験用クラス

実験用に、Rahmenクラスを作成。

infoment.hatenablog.com

こちらの記事にインスパイヤされたでござる。

クラスモジュール Rahmen

Option Explicit

'///Attribute VB_PredeclaredId = True///'

Public Enum NoodleSolidity
  nsYugeTooshi
  nsKonaOtoshi
  nsHarigane
  nsBariKata
  nsKata
  nsFutsuu
  nsYawa
  nsZundare
End Enum

Private count_ As Long

Private solidity_ As String

Public Property Get Solidity() As String
  Solidity = solidity_
End Property

Public Property Let Count(ByVal value_ As Long)
  count_ = value_
End Property

Public Property Get Kaedama() As String
  Kaedama = CStr(count_) & "玉目"
End Property

Private Sub Class_Initialize()
  solidity_ = "ふつう"
End Sub

Public Sub setSolidity(ByVal solidityArg As NoodleSolidity)
  solidity_ = getSolidityString(solidityArg)
End Sub

Private Function getSolidityString( _
             ByVal arg As NoodleSolidity) As String
  Dim ret As String
  Select Case arg
    Case nsYugeTooshi: ret = "湯気とおし"
    Case nsKonaOtoshi: ret = "粉落とし"
    Case nsHarigane: ret = "ハリガネ"
    Case nsBariKata: ret = "バリカタ"
    Case nsKata: ret = "カタ"
    Case nsFutsuu: ret = "ふつう"
    Case nsYawa: ret = "やわ"
    Case nsZundare: ret = "ずんだれ"
    Case Else: ret = "ち~んw"
  End Select
  getSolidityString = ret
End Function

Public Function getInstance( _
            ByVal solidity__ As NoodleSolidity) As Rahmen
  Dim ret As New Rahmen
  Call ret.setSolidity(solidity__)
  count_ = count_ + 1
  ret.Count = count_  '……(*)'
  Set getInstance = ret
End Function

例によって、Attribute VB_PredeclaredIdTrueにしている。

NoodleSolidityという列挙体をPublicで宣言しているので、このクラスモジュールをインポートしたプロジェクトでは、この列挙体を使用することができる。

基本的に、getInstanceメソッド内でsetSolidityメソッドに渡すための引数に用いる。

setSolidityメソッドからは、getSolidityStringメソッドを呼んで、〈麺のかたさ〉を表す文字列を取得する。一番かたい「湯気とおし」から一番やわらかい「ずんだれ」まで、無駄にヴァリエーション豊富にしたw

Solidityプロパティ

変数solidity_の内容を返すだけ。

変数solidity_に値をセットするのは、デフォルトのコンストラクタであるClass_Initializeか、インスタンスメソッドのsetSolidity(とそこから呼ばれるgetSolidityStringメソッド)のみ。

setSolidityNoodleSolidity列挙体のメンバを引数として渡すと、対応する〈麺のかたさ〉を表す文字列を取得して変数solidity_にセットする。

Kaedamaプロパティ

変数count_に入っている数値を文字列に変換し、「玉目」を附加した文字列を返す。

実は、getInstanceメソッドをRahmen.getInstanceの形で呼び出したとき、メソッド内部の変数count_には、Rahmen内部の(インスタンスのものでない)変数count_の値が入っている。

この性質を生かして、クラス変数的なことができないものか、と考えたわけです。

そこで、getInstanceメソッドの(*)のところ、

ret.Count = count_

とした。

こうすることで、Rahmenが持っているcount_の数値をインスタンスが持っている変数count_にセットするのだ。

逆にいえば、retCountプロパティにセットする、という形にしないと、インスタンス内部のcount_を変更できないらしい。

実は、このことが大問題の原因になる。後述する。

とりあえず使ってみる

標準モジュールに次のコードを書いて使ってみる。

リスト1 標準モジュール
Public Sub disposable01()
  Dim rahmen1 As Rahmen
  Set rahmen1 = Rahmen.getInstance(nsKonaOtoshi)
  Dim rahmen2 As Rahmen
  Set rahmen2 = Rahmen.getInstance(nsBariKata)
  Dim rahmen3 As Rahmen
  Set rahmen3 = Rahmen.getInstance(nsZundare)
  Call printData(rahmen1)
  Call printData(rahmen2)
  Call printData(rahmen3)
  Debug.Print Rahmen.Kaedama
End Sub

Private Sub printData(ByVal targetRahmen As Rahmen)
  With targetRahmen
    Debug.Print "替え玉:" & .Kaedama; _
                "/麺のかたさ:" & .Solidity
  End With
End Sub

見ておわかりのとおり、rahmen1rahmen2rahmen3の三つのRahmen型変数を準備し、それぞれRahmen.getInstanceメソッドでインスタンス化する。

あとは、printDataメソッドを用いて、それぞれのKaedamaプロパティとSolidityプロパティ、すなわち〈麺のかたさ〉を表示し、最後にRahmenオブジェクト自体のKaedamaプロパティを表示しておしまい。

実行結果

一回目。

f:id:akashi_keirin:20190502204015j:plain

二回目。

f:id:akashi_keirin:20190502204018j:plain

一応、意図どおりの結果が出ている。

クラス内の変数count_が、クラス変数のような働きをしている。

大問題

〈麺のかたさ〉を設定するsetSolidityメソッドはともかく、Property Let CountPublicだというのは非常にまずい。

count_が外部から自在に書き換えられてしまうからである。

あと、setSolidityメソッドにしても、単独でこのメソッドを実行するだけなら、Rahmen内部の変数count_は変化しないので、おかしなことになる。

おわりに

まだまだ解決せねばならんことが多い……。

Errオブジェクトをラップしたクラス

Errオブジェクトをラップしたクラス

akashi-keirin.hatenablog.com

このとき、ErrObjectクラスはインスタンス化できないことを示した。

よく「Errオブジェクト」という表現も見かけるが、

Set hoge = New Err

という書き方ができるわけでもない。

ただ、イミディエイト・ウインドウで

?TypeName(Err)

と書いて[Enter]を押すと、ErrObjectが返る。

……ということは、よく使うErrというやつは、ErrObjectクラスの唯一のインスタンスなのか……???

この辺はよくわからん。

とにかく、エラーが出たときに、そのエラーそのものを外に投げられたらいいのに、と思ったので、Errオブジェクトをラップしたクラスを作ってみた。

ErrorObjectクラス

Error」も「ErrObject」も既に使われているオブジェクト名なので、オブジェクト名は「ErrorObject」にした。うーん、イマイチ。

ちなみに、Attribute VB_PredeclaredId = Trueにしている。

クラスモジュール ErrorObject
Option Explicit

'///Attribute VB_PredeclaredId = True///'

Private number_ As Long
Private description_ As String
Private lastDllError_ As Long
Private source_ As String

Public Property Get Number() As Long
  Number = number_
End Property
Public Property Let Number(ByVal value_ As Long)
  number_ = value_
End Property

Public Property Get Description() As String
  Description = description_
End Property
Public Property Let Description(ByVal value_ As String)
  description_ = value_
End Property

Public Property Get LastDllError() As Long
  LastDllError = lastDllError_
End Property
Public Property Let LastDllError(ByVal value_ As Long)
  lastDllError_ = value_
End Property

Public Property Get Source() As String
  Source = source_
End Property
Public Property Let Source(ByVal value_ As String)
  source_ = value_
End Property

Public Sub clearError()
  number_ = 0
  description_ = ""
  lastDllError_ = 0
  source_ = ""
  Call Err.Clear
End Sub
Public Sub raiseError( _
             Optional ByVal number__ As Long, _
             Optional ByVal source__ As Long, _
             Optional ByVal description__ As String)
  If number__ > 0 Then number_ = number__
  If source__ > 0 Then source_ = source__
  If description__ <> "" Then description_ = description__
  If number_ = 0 Then Exit Sub
  Call Err.Raise(number_, source_, description_)
End Sub

Public Function getInstance( _
                  ByVal number__ As Long, _
         Optional ByVal description__ As String, _
         Optional ByVal source__ As String, _
         Optional ByVal lastDllError__ As Long) As ErrorObject
  Dim ret As New ErrorObject
  ret.Number = number__
  ret.Description = description__
  ret.Source = source__
  ret.LastDllError = lastDllError__
  Set getInstance = ret
End Function

ホントにただErrオブジェクトをラップしただけ。getInstanceメソッドでインスタンスを吐くようにしたけれど、意味があるのかどうなのかわからない。

使ってみる

標準モジュールに次のようなコードを書いて実験。

リスト1 標準モジュール
Option Explicit

Private ret As ErrorObject
Private errorSource As String

Public Sub test()
  Dim result As ErrorObject
  Set result = aCertainProcess
  With result
    Debug.Print "Number:" & .Number
    Debug.Print "Description:" & .Description
    Debug.Print "Source:" & .Source
    Debug.Print "LastDLLError:" & .LastDllError
  End With
End Sub

Private Function aCertainProcess() As ErrorObject
  On Error Resume Next
  Call process1
  If Err.Number > 0 Then _
    errorSource = "手順1": GoTo ErrorHandler
  Call process2
  If Err.Number > 0 Then _
    errorSource = "手順2": GoTo ErrorHandler
  Call process3
  If Err.Number > 0 Then _
    errorSource = "手順3": GoTo ErrorHandler
ErrorHandler:
  Set ret = ErrorObject.getInstance( _
              Err.Number, Err.Description, errorSource, Err.LastDllError)
  Call Err.Clear
  Set aCertainProcess = ret
  Set ret = Nothing
End Function

Private Sub process1()
  
End Sub

Private Sub process2()
  
End Sub

Private Sub process3()
  Call Err.Raise(5)
End Sub

aCertainProcessメソッドの返り値をErrorObject型にしている。

aCertainProcessからは、process1process2process3の各メソッドを呼び出す。process1process2では何も起きないが、process3メソッドを実行すると、エラー番号「5」の実行時エラーが起きる。

aCertainProcessメソッドでは、process1process2process3の各メソッドを実行するごとにErr.Numberプロパティを調べ、「0」を超える数値が返ったら、すなわちエラーが起きていたら、変数errorSourceに処理の場所を表す文字列をセットして、ErrorHandlerラベルに飛ぶ。

ErrorHandlerラベル以下では、そのときのErrオブジェクトの状態を転写したErrorObjectクラスのインスタンスを作成してreturn。

呼び出し元のtestプロシージャでは、返り値であるErrorObjectクラスのインスタンスが持っている諸データをイミディエイトに出力する。

実行結果

実行後のイミディエイト・ウインドウが

f:id:akashi_keirin:20190501165209j:plain

これ。

おわりに

まあ、これぐらいのことなら別に構造体でいいよな。