| 投稿日 | ： 2006/09/22(Fri) 14:33 |
| 投稿者 | ： neptune |
| Ｅメール | ： |
| ＵＲＬ | ： |
| タイトル | ： Re^4: EXCEL2000のVBAでIMEHoldを実現する |
こんにちは
> 「ラベル付テキスト」の話題はWebでかなり見かけますがサンプルコードが見つかりません。
> どこかに無いでしょうか？それの改修なら行けそうです。
ラベル付きってのを忘れて作ってしまって書き込もうとしたら
ラベル付きって発見しました。^ ^;
ラベル用子クラスをもうひとつと、Class１にそれ用のコレクションをもうひとつ
作ったら出来ませんかね。
サンプルにもなりませんが、せっかく書いたんでUPしときます。
実験は新規Bookでしてください。
UserFormにTextBoxを３個、コマンドボタンを１個貼り付けてください。名前はデフォルト。
UserForm表示後、マウスカーソルをTextBoxの上を通過させると入力されたデータ
がmsgboxで表示されます。（鬱陶しい！）
ちょっとしか確認してませんので変なところがあったら直してください。
'///////////////////UserForm///////////////////////
Option Explicit
Private clsTxt As Class1
Private Sub CommandButton1_Click()
With clsTxt
MsgBox "TextBox1のデータ : " & .Items(1).Text & vbCrLf & _
"TextBox2のデータ : " & .Items(2).Text & vbCrLf & _
"TextBox1のデータ : " & .Items(3).Text & _
"を全て消去します。"
.EraseAllData
End With
End Sub
Private Sub UserForm_Initialize()
Set clsTxt = New Class1
clsTxt.AddItem = Me.TextBox1
clsTxt.AddItem = Me.TextBox2
clsTxt.AddItem = Me.TextBox3
Me.CommandButton1.Caption = "全データ消去"
End Sub
Private Sub UserForm_Terminate()
Set clsTxt = Nothing
End Sub
'///////////////////////////Class1/////////////////
Option Explicit
Private clsItem As Class2
Private mCollection As Collection
Public Property Let AddItem(ptxt As MSForms.TextBox)
Set clsItem = New Class2
Set clsItem.SetTextBox = ptxt
mCollection.Add clsItem
End Property
Public Property Get Items(pNum As Long) As MSForms.TextBox
Set Items = mCollection(pNum).GetTextBox
End Property
'全てのデータ消去
Public Function EraseAllData()
Dim clsBuf As Class2
Dim I As Long
For I = 1 To mCollection.Count
mCollection(I).DelText
Next I
End Function
Private Sub Class_Initialize()
Set mCollection = New Collection
End Sub
Private Sub Class_Terminate()
Set mCollection = Nothing
End Sub
'////////////////////////Class2/////////////////////
Option Explicit
Private WithEvents mTxt As MSForms.TextBox
Property Set SetTextBox(ptxt As MSForms.TextBox)
Set mTxt = ptxt
End Property
Property Get GetTextBox() As MSForms.TextBox
Set GetTextBox = mTxt
End Property
Public Function DelText()
mTxt.Text = ""
End Function
Private Sub Class_Terminate()
Set mTxt = Nothing
End Sub
Private Sub mTxt_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
MsgBox mTxt.Text
End Sub