自身のインスタンスを返すクラス
自分自身のインスタンスを返すクラス
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クラスを利用してみる。
リスト１ 標準モジュール
Public Sub disposable01() HelloWorld.sayHello End Sub
たったこれだけ。インスタンス化せずに使おうとしてみる。既にコード入力時から入力補完も利かないのでダメだろうと予想がつく。実行してみると、
予想通り、そもそもコンパイルが通らず、実行不可。
Attribute VB_PredeclaredId = True のとき
そこで、一旦このHelloWorld.clsをエクスポートして、エディタで開く。
このように、Attribute VB_PredeclaredIdのところの右辺をTrueに変えて保存する。
HelloWorld.clsをインポートして、再度リスト１を実行。
今度は無事実行できた。
ちなみに、次のようにしても同じ結果が出る。
リスト２ 標準モジュール
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プロパティの値がデフォルト値になってしまう。
このカラクリがわからず、しばらくハマってしまった……。
使ってみる
次のコードで実験
リスト３ 標準モジュール
Public Sub disposable01()
Dim greeterMan2 As HelloWorld
Set greeterMan2 = HelloWorld.getInstance("ち～んｗ")
greeterMan2.sayHello
End Sub
こいつを実行すると、
ちゃんと引数を渡してインスタンス化したような結果が得られた。
おわりに
何か面白いことに使えないかなあ。
ErrObjectクラスはインスタンス化できない？
ErrObjectクラスはインスタンス化できない？
よく、「Errオブジェクト」という言葉を目にする。
エラー処理に便利なのでよく使うのも事実。
今朝、不意に「オブジェクト？ じゃあ、インスタンス化できるのか？」と思った。
やってみた
テキトーにプロシージャを作って、
Dim errObj As Err
まで打ち込んでみると、
フツーにErrObjectが入力候補に出てくる。
も、もしかして……。期待が高まる。
改行して、
Set errObj = New Err
まで打ち込んでみると、
またしてもErrObjectが入力候補に！ もう辛抱たまらん！
さらに改行して、
errObj.
と入力すると……
うひょーーーー！ もう昇天寸前！
結局、次のようなコードが完成。
リスト１ 標準モジュール
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の場合、受信確認をオンにするのは非常に簡単。
(*)のところの２行（実質１行）
If allowRetReceipt Then _
.ReadReceiptRequested = True
こんだけ。
MailItemオブジェクトのReadReceiptRequestedプロパティをTrueにしてやるだけでよい。
使ってみる
Thunderbird同様、Outlookも家のPCにフツーに入っているので、実験可能。
ちゃんと動いた。
createMailメソッドの第６引数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
'左肩部分の下に２行文空行をセット'
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ポイントで４文字分右にずらそうと思ったら、イミディエイト・ウインドウに
ThisDocument.Tables(1).Rows.LeftIndent = 10.5 * 4
と打ち込んで[Enter]を押せば良い。
こうなる。
「表のプロパティ」を見てみると、
このとおり。mm単位なので分かりにくいけれど、10.5ポイントの全角文字の幅が3.7mmなので、ちょうど４文字分だということがわかるだろう。
表の幅を設定してから表全体を右にずらすマクロ
前回
のコードにコードを追加して、表全体の幅を設定してから表全体を右に４文字分ずらすことを試みる。
リスト１ 標準モジュール
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
前回のリスト３から変えたのは(*)からの２行だけ。
200ミリ秒待機した後、４文字分右にずらす処理を加えただけ。
こいつを実行すると、
なぜかこうなる。
前回はなぜか後回しにされてしまっていた表全体の幅を変更する処理が、今度は完全に無視されてしまった。
実は、
targetTable.Rows.LeftIndent = 10.5 * 4
にブレークポイントを設定して、ステップ実行してやると、普通に処理が行われる。
ノンストップで実行すると（それが普通の実行方法なんだけど）、ものの見事に無視されるのだ。
メソッドとして切り出してみる
表全体の幅を変更する処理の部分をメソッドとして切り出したらどうなるのか、やってみた。
リスト２ 標準モジュール
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メソッドを用いる。
リスト１ 標準モジュール
Dim targetTable As Table With ThisDocument Set targetTable = .Tables.Add(Selection.Range, 5, 5) End With
たとえば、このようにすれば、カーソル位置に５行×５列の表を挿入することができる。ちなみに、この例では、挿入した表をすかさず変数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に指定しておくと、表の横幅をポイント単位で指定できるようだ。
リスト２ 標準モジュール
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 = "ち～んｗ"
とすれば、５行×５列の表をカーソル位置に挿入し、しかる後その表の２行２列のセルに「ち～んｗ」と書き込むことができる。
リスト３ 標準モジュール
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)
- カーソル位置に５行×５列の表を挿入 ……(2)
- 表の横幅を
240ポイントにする ……(3) - 表の各セルに数字を記入 ……(4)
となるはずである。
実行
リスト３を実行すると、
こうなる。
Tableオブジェクトのサイズ変更が後回しにされてしまうのだ。
