自身のインスタンスを返すクラス
自分自身のインスタンスを返すクラス
Attribute VB_PredeclaredId = False のとき
クラスモジュールをデフォルトで使うときは、
Attribute VB_PredeclaredId = False
である。
このとき、クラスのメソッドやプロパティは、インスタンス化した後でないと利用できない。
たとえば、次のようなクラスがあったとする。
クラスモジュール HelloWorld
Option Explicit 'Constants' Private Const DEFAULT_MESSAGE As String = "Hello, World!" 'Module Level Variables' Private message_ As String 'Properties' Public Property Get Message() As String If message_ = "" Then _ Message = DEFAULT_MESSAGE: Exit Property Message = message_ End Property Public Property Let Message(ByVal value_ As String) If Len(value_) > 20 Then message_ = "": Exit Property message_ = value_ End Property 'Constructor' Private Sub Class_Initialize() message_ = DEFAULT_MESSAGE End Sub 'Methods' Public Sub sayHello() Call MsgBox(message_) End Sub
無駄に長くて済まない。
Message
というプロパティと、sayHello
というメソッドを持ったクラス。
Message
プロパティはRead/Writeで、デフォルトでは「Hello, World!
」という値になるようにしている。あと、せっかくProperty Let
を使うので、無駄に20字を超えると空文字にするようにしている。
使ってみる
このHelloWorld
クラスを利用してみる。
リスト1 標準モジュール
Public Sub disposable01() HelloWorld.sayHello End Sub
たったこれだけ。インスタンス化せずに使おうとしてみる。既にコード入力時から入力補完も利かないのでダメだろうと予想がつく。実行してみると、
予想通り、そもそもコンパイルが通らず、実行不可。
Attribute VB_PredeclaredId = True のとき
そこで、一旦このHelloWorld.cls
をエクスポートして、エディタで開く。
このように、Attribute VB_PredeclaredId
のところの右辺をTrue
に変えて保存する。
HelloWorld.cls
をインポートして、再度リスト1を実行。
今度は無事実行できた。
ちなみに、次のようにしても同じ結果が出る。
リスト2 標準モジュール
Public Sub disposable01() Dim greeterMan1 As New HelloWorld greeterMan1.sayHello End Sub
つまり、Attribute VB_PredeclaredId = True
のときは、インスタンス化してもしなくてもクラスのメソッド、プロパティが利用可能だということらしい。
自身のインスタンスを返すメソッド
ならば、自身のインスタンスを返すメソッドを内包させることができるはず。
上のHelloWorld
クラスのコードを次のように書き換える。
クラスモジュール HelloWorld
Option Explicit '///Attribute VB_PredeclaredId = True///' 'Constants' Private Const DEFAULT_MESSAGE As String = "Hello, World!" 'Module Level Variables' Private message_ As String 'Properties' Public Property Get Message() As String If message_ = "" Then _ Message = DEFAULT_MESSAGE: Exit Property Message = message_ End Property Public Property Let Message(ByVal value_ As String) If Len(value_) > 20 Then message_ = "": Exit Property message_ = value_ End Property 'Constructor' Private Sub Class_Initialize() message_ = DEFAULT_MESSAGE End Sub 'Methods' Public Sub sayHello() Call MsgBox(message_) End Sub Public Function getInstance( _ ByVal messageString As String) As HelloWorld '……(*)' Dim ret As HelloWorld Set ret = New HelloWorld ret.Message = messageString '……(**)' Set getInstance = ret End Function
冒頭に入れたように、Attribute VB_PredeclaredId
をTrue
にした場合は、コメントで明示しておいた方がいいと思う。
新たに加えたのは(*)のgetInstance
メソッド。
ちょっと気をつけないといけないのは、(**)の部分。
ここを
message_ = messageString
としてしまうと、getInstance
メソッドが返すインスタンスのMessage
プロパティの値がデフォルト値になってしまう。
このカラクリがわからず、しばらくハマってしまった……。
使ってみる
次のコードで実験
リスト3 標準モジュール
Public Sub disposable01() Dim greeterMan2 As HelloWorld Set greeterMan2 = HelloWorld.getInstance("ち~んw") greeterMan2.sayHello End Sub
こいつを実行すると、
ちゃんと引数を渡してインスタンス化したような結果が得られた。
おわりに
何か面白いことに使えないかなあ。
ErrObjectクラスはインスタンス化できない?
ErrObjectクラスはインスタンス化できない?
よく、「Err
オブジェクト」という言葉を目にする。
エラー処理に便利なのでよく使うのも事実。
今朝、不意に「オブジェクト? じゃあ、インスタンス化できるのか?」と思った。
やってみた
テキトーにプロシージャを作って、
Dim errObj As Err
まで打ち込んでみると、
フツーにErrObject
が入力候補に出てくる。
も、もしかして……。期待が高まる。
改行して、
Set errObj = New Err
まで打ち込んでみると、
またしてもErrObject
が入力候補に! もう辛抱たまらん!
さらに改行して、
errObj.
と入力すると……
うひょーーーー! もう昇天寸前!
結局、次のようなコードが完成。
リスト1 標準モジュール
Public Sub disposable01() Dim errObj As ErrObject Set errObj = New ErrObject errObj.Number = 1 Debug.Print errObj.Number End Sub
ErrObject
オブジェクトのNumber
プロパティに「1
」を代入し、その値をイミディエイトに出力しようという魂胆。
実行
期待に胸躍らせながら実行!
え? どういうことっすか???
何か参照設定が足りないとか?
詳しい人、教えろ教えてください。
おわりに
もしかして、ClassではなくModuleなんではないか、と思いましたが、オブジェクト ブラウザーで見る限り、
Classでした。
Outlookのメールを作成するクラスを作った
Outlookのメールを作成するクラスを作った
一気にOutlook版も行っちゃうよ!
今回も、
このときのRecipient
クラス、Sender
クラスと併用するのが前提。
ソースコード
クラスモジュール OutlookApp
Option Explicit Implements IMailCreatable 'Module Level Variables' Private olApp As Outlook.Application Private isAvailable As Boolean 'Constructor' 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 'Methods' Public Sub 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) If Not isAvailable Then Exit Sub '本文文字列の作成' '左肩部分の作成' 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 Dim targetMailItem As MailItem 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 '添付ファイルの設定' For i = LBound(attFilePath) To UBound(attFilePath) If attFilePath(i) <> "" Then _ Call .Attachments.Add(attFilePath(i)) Next '受信確認設定 ……(*)' If allowRetReceipt Then _ .ReadReceiptRequested = True End With End Sub 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
Outlookの場合、受信確認をオンにするのは非常に簡単。
(*)のところの2行(実質1行)
If allowRetReceipt Then _ .ReadReceiptRequested = True
こんだけ。
MailItem
オブジェクトのReadReceiptRequested
プロパティをTrue
にしてやるだけでよい。
使ってみる
Thunderbird同様、Outlookも家のPCにフツーに入っているので、実験可能。
ちゃんと動いた。
createMail
メソッドの第6引数allowRetReceipt
をTrue
にして実行したので、このように「開封確認の要求」にチェックが入っている。
おわりに
これで、普段使っているメールアプリが出揃ったぞ。
Thunderbirdのメールを作成するクラスを作った
Thunderbirdメール作成用のクラスを作成した
今度はThunderbird用。
前回
のRecipient
クラス、Sender
クラスは、今回も使用する。
ソースコード
クラスモジュール ThunderbirdApp
Option Explicit Implements IMailCreatable Private exePath As String Private isAvailable As Boolean 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 Sub 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) If Not isAvailable Then Exit Sub '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 End Sub
エラー対応なんかはまだ。
あと、受信確認を設定する方法がわからないので、IMailCreatable_createMail
メソッドの引数allowReturnReceipt
が何の意味もなく設定されている。
IMailCreatable
インターフェースで引数も含めて定義したために、削ることができなかった。
IMailCreatable
インターフェース内で、
Public sub createMail() End Sub
とすればいいのだけれど、そうするとIMailCreatable
型の変数を用いる場合に引数のヒントが出ない。
インターフェースまわりはまだよくわかっていないところが多いので、どなたかアドヴァイスくれよろしく。
使ってみる
LotusNotesと違って、Thunderbirdは家のPCにもフツーに入っているので実験可能。
ちゃんと動いた。
おわりに
あとはOutlookやな……。
……っていうか、複数のクラスをまとめて利用する必要があるので、
このときみたいに丸ごと外出しして、アドインにした方が使い勝手が良いのかも。
め、めんどくさーーーー!
LotusNotesのメールを作成するクラスを作ってみた
LotusNotesのメールを作成するクラスを作ってみた
作ってみた。
しかし、LotusNotesは職場のPCに入っているので、全く実験できていない。
ちゃんと動くかどうかまるで未検証。
とりあえずコードだけぶちまけておいて、動作確認ができ次第修正していくことにする。
内容
LotusNotesAppクラス
メールを作成するメインのクラス。
IMailCreatableインターフェース
今後、LotusNotes以外のメールアプリもクラス化していく予定なので、インターフェースを持たせておく。
Recipientクラス
メールの送り先に関する情報をまとめたクラス。
Senderクラス
メールの送り手に関する情報をまとめたクラス。
ざっとこんな感じ。
ソースコード
クラスモジュール LotusNotesApp
Option Explicit Implements IMailCreatable Private Const EMBED_ATTACHMENT As Long = 1454 Private Const MAIN_FONTSIZE As Double = 12 Private Const SUB_FONTSIZE As Double = 10 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 isAvailable As Boolean Public Property Get NotesSession() As Object Set NotesSession = notesSession_ End Property Public Property Get NotesUIWorkspace() As Object Set NotesUIWorkspace = notesUIWorkspace_ End Property Public Sub init() Set notesSession_ = CreateObject("Notes.NotesSession") Set notesUIWorkspace_ = CreateObject("Notes.NotesUIWorkspace") Set notesDatabase_ = notesSession_.getDatabase("", "") '現在のユーザーのメールデータベースに割り当て、そのデータベースを開く' Call notesDatabase_.openMail isAvailable = True End Sub Private Sub Class_Initialize() isAvailable = False 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 End Sub Public Sub 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) If Not isAvailable Then Exit Sub '受信確認設定準備' 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) '添付ファイルを追加する' Set notesRichTextItem = getFileAttachedRichTextItem(notesRichTextItem, _ attFilePath()) '署名を附加する' Set notesRichTextItem = getSignAppendedRichTextItem(notesRichTextItem, _ currentSender) 'メールを保存する' Call notesDocument.Save(False, False) 'メールを編集状態にする' Set notesUIDocument = notesUIWorkspace_.EditDocument(True, notesDocument, False) End Sub 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
※2019.4.28 23:15ごろ、一部を修正しました。
クラスモジュール IMailCreatable
Option Explicit Public Sub createMail(ByVal targetRecipient As Recipient, _ ByVal currentSender As Sender, _ ByVal mailSubject As String, _ ByRef mailBody() As String, _ ByRef attFilePath() As String, _ ByVal allowRetReceipt As Boolean) End Sub
クラスモジュール 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, _ ByVal CC As String, _ 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
※2019.4.28 23:15ごろ、一部を修正しました。
とりあえず
Recipient
クラスとSender
クラスは、LotusNotesApp
クラスのcreateMail
メソッドの引数にする。
LotusNotesApp
クラスのcreateMail
メソッドは、引数としてRecipient
クラスのインスタンス、Sender
クラスのインスタンス、メールの件名、メール本文(文字列データの配列)、添付ファイルのフルパスを格納した配列、受信確認の有無を渡すと、添付ファイル付きのメールを作成して表示する。
最初にも書いたように、全然動作確認ができていないので、ご了承ください。
追記
ほんの少しだけ動作確認をした結果、一部コードを修正しました。
表の位置を右にずらす(Word)
表の横位置を変更する
ドキュメント内の表の横位置を変える方法が判明したので、メモ代わりに記しておく。
RowsオブジェクトのLeftIndentプロパティを使う
表の位置なので、Table
オブジェクトのプロパティを触ればよいと思っていたが、違った。
左端にある表を右にずらすには、Table.Rows
オブジェクトのLeftIndent
プロパティに値を設定する。
たとえば、
この表を右側に10.5ポイントで4文字分右にずらそうと思ったら、イミディエイト・ウインドウに
ThisDocument.Tables(1).Rows.LeftIndent = 10.5 * 4
と打ち込んで[Enter]を押せば良い。
こうなる。
「表のプロパティ」を見てみると、
このとおり。mm単位なので分かりにくいけれど、10.5ポイントの全角文字の幅が3.7mmなので、ちょうど4文字分だということがわかるだろう。
表の幅を設定してから表全体を右にずらすマクロ
前回
のコードにコードを追加して、表全体の幅を設定してから表全体を右に4文字分ずらすことを試みる。
リスト1 標準モジュール
Public Sub test02() Dim Doc As Document Set Doc = ThisDocument Call deleteTables(Doc) Dim targetTable As Table With Doc Set targetTable = .Tables.Add(Selection.Range, 5, 5) End With Dim r As Long Dim c As Long Dim n As Long n = 1 Dim targetCell As Cell With targetTable .PreferredWidthType = wdPreferredWidthPoints .PreferredWidth = 240 Call Application.ScreenRefresh For r = 1 To .Rows.Count For c = 1 To .Columns.Count .Cell(r, c).Range.Text = n n = n + 1 Call WindowsAPI.waitFor(200) Next Next End With Call WindowsAPI.waitFor(200) '……(*)' targetTable.Rows.LeftIndent = 10.5 * 4 End Sub Private Sub deleteTables(ByVal targetDocument As Document) Dim tablesCount As Long tablesCount = targetDocument.Tables.Count If tablesCount = 0 Then Exit Sub Dim i As Long For i = tablesCount To 1 Step -1 Call targetDocument.Tables(i).Delete Next End Sub
前回のリスト3から変えたのは(*)からの2行だけ。
200ミリ秒待機した後、4文字分右にずらす処理を加えただけ。
こいつを実行すると、
なぜかこうなる。
前回はなぜか後回しにされてしまっていた表全体の幅を変更する処理が、今度は完全に無視されてしまった。
実は、
targetTable.Rows.LeftIndent = 10.5 * 4
にブレークポイントを設定して、ステップ実行してやると、普通に処理が行われる。
ノンストップで実行すると(それが普通の実行方法なんだけど)、ものの見事に無視されるのだ。
メソッドとして切り出してみる
表全体の幅を変更する処理の部分をメソッドとして切り出したらどうなるのか、やってみた。
リスト2 標準モジュール
Public Sub test02() Dim Doc As Document Set Doc = ThisDocument Call deleteTables(Doc) Dim targetTable As Table With Doc Set targetTable = .Tables.Add(Selection.Range, 5, 5) End With Dim r As Long Dim c As Long Dim n As Long n = 1 Dim targetCell As Cell With targetTable .PreferredWidthType = wdPreferredWidthPoints .PreferredWidth = 240 Call Application.ScreenRefresh For r = 1 To .Rows.Count For c = 1 To .Columns.Count .Cell(r, c).Range.Text = n n = n + 1 Call WindowsAPI.waitFor(200) Next Next End With Call WindowsAPI.waitFor(200) targetTable.Rows.LeftIndent = 10.5 * 4 Call resizeTable(targetTable, 240) '……(**)' End Sub Private Sub deleteTables(ByVal targetDocument As Document) Dim tablesCount As Long tablesCount = targetDocument.Tables.Count If tablesCount = 0 Then Exit Sub Dim i As Long For i = tablesCount To 1 Step -1 Call targetDocument.Tables(i).Delete Next End Sub Private Sub resizeTable(ByVal targetTable As Table, _ ByVal targetSize As Double) With targetTable .PreferredWidthType = wdPreferredWidthPoints .PreferredWidth = targetSize End With End Sub
三つ目のresizeTable
が、表全体の幅を変更するメソッド。見たらわかると思うけど。
こいつを、(**)のところで使用している。
これならばどうか。
意図どおりに動いている。
おわりに
やっぱりちょっとわけがわかりません。
追記
ちなみに、このやり方で表を挿入した場合、表の外にカーソルがないので、表の外側に一切文字を入力することができなくなるような気がします。
何か、打開策はあるのでしょうか???
さらに追記
すんません。カーソルがなくなったのではなく、何らかの手違いで段落のインデント幅がえげつない数値になっており、画面の外に追い出されていただけのようでした。
お騒がせしました。
落ち着いて「段落」タブを開けるか、イミディエイト・ウインドウでParagraphs
コレクションのCount
プロパティを調べるべきだと思いました。
Tableオブジェクトの謎挙動(Word)
Tableオブジェクトの謎挙動(Word)
なんだかよくわからん現象が起こるので報告。
ドキュメントに表を挿入する
ドキュメントに表を挿入するには、Document.Tables
コレクションのAdd
メソッドを用いる。
リスト1 標準モジュール
Dim targetTable As Table With ThisDocument Set targetTable = .Tables.Add(Selection.Range, 5, 5) End With
たとえば、このようにすれば、カーソル位置に5行×5列の表を挿入することができる。ちなみに、この例では、挿入した表をすかさず変数targetTable
にぶちこんでいるが、単に表をカーソル位置に挿入するだけなら
Call .Tables.Add(Selection.Range, 5, 5)
このようにすればよい。
表のサイズを変える
上記のやり方だと、表の大きさ(横幅)は印刷範囲の横幅いっぱいになる。
表の横幅を変えるには、PreferredWidth
に値を設定してやればよい。
ただし、『Word 2013 developers docs』の「Table.PreferredWidth Property (Word) 」の項によると、
If the PreferredWidthType property is set to wdPreferredWidthPoints, the PreferredWidth property returns or sets the width in points. If the PreferredWidthType property is set to wdPreferredWidthPercent, the PreferredWidth property returns or sets the width as a percentage of the window width.
とある。PreferredWidthType
プロパティに設定する値によって、PreferredWidth
プロパティに設定する数字の意味が変わるらしい。
たとえば、PreferredWidthType
の値をwdPreferredWidthPoints
に指定しておくと、表の横幅をポイント単位で指定できるようだ。
リスト2 標準モジュール
Dim targetTable As Table With ThisDocument Set targetTable = .Tables.Add(Selection.Range, 5, 5) End With With targetTable .PreferredWidthType = wdPreferredWidthPoints .PreferredWidth = 240 End With
たとえば、このようにすると、表全体の横幅を240
ポイントに設定できるっぽい。
表の各セルに値を書き込む
表の各セルは、Table
オブジェクトのCell
メソッドで取得できる。
Cell
メソッドをオブジェクト ブラウザーで見てみると、
Function Cell(Row As Long, Column As Long) As Cell
Word.Table のメンバー
とあるので、Cell
メソッドはCell
オブジェクトを返す、言い換えるとCell
メソッドを実行するとCell
オブジェクトを取得する、ということだ。
Cell
オブジェクトの配下にはRange
オブジェクトがあり、そのRange
オブジェクトのText
プロパティに文字列を設定してやれば、セルに文字を書き込んだことになる。
うむ。だいぶWordのオブジェクト・モデルに慣れてきたぞ。
したがって、たとえば、
Dim targetTable As Table With ThisDocument Set targetTable = .Tables.Add(Selection.Range, 5, 5) End With targetTable.Cell(2, 2).Range.Text = "ち~んw"
とすれば、5行×5列の表をカーソル位置に挿入し、しかる後その表の2行2列のセルに「ち~んw」と書き込むことができる。
リスト3 標準モジュール
Public Sub test02() Dim Doc As Document Set Doc = ThisDocument Call deleteTables(Doc) '……(1)' Dim targetTable As Table With Doc '……(2)' Set targetTable = .Tables.Add(Selection.Range, 5, 5) End With Dim r As Long Dim c As Long Dim n As Long n = 1 Dim targetCell As Cell With targetTable .PreferredWidthType = wdPreferredWidthPoints '……(3)' .PreferredWidth = 240 For r = 1 To .Rows.Count '……(4)' For c = 1 To .Columns.Count .Cell(r, c).Range.Text = n n = n + 1 Call WindowsAPI.waitFor(200) '……(*)' Next Next End With End Sub Private Sub deleteTables(ByVal targetDocument As Document) Dim tablesCount As Long tablesCount = targetDocument.Tables.Count If tablesCount = 0 Then Exit Sub Dim i As Long For i = tablesCount To 1 Step -1 Call targetDocument.Tables(i).Delete Next End Sub
(*)のWindowsAPI
クラスについては、
コチラをどうぞ。
セルに数字を書き込むごとに200ミリ秒待機するようにしている。
さて、上掲コードを実行すると、
- ドキュメント上の表を消去 ……(1)
- カーソル位置に5行×5列の表を挿入 ……(2)
- 表の横幅を
240
ポイントにする ……(3) - 表の各セルに数字を記入 ……(4)
となるはずである。
実行
リスト3を実行すると、
こうなる。
Table
オブジェクトのサイズ変更が後回しにされてしまうのだ。