vbaマクロで、色の設定ダイアログ画面について

質問

動作環境
OS:Windows7(64Bit) Home Premium SP1
MS:Office Version2007 SP3

下記のURLを参考にして、色の設定ダイアログ画面を出力させました。
ところが、この画面、モーダレス出力をモーダル出力にさせたいのですが、
方法が分かりません。
ちなみに、Excelのvbaで、試しています。
どなたか、ご指導願います。

■色の設定ダイアログ画面(URL)
http://www.tsware.jp/tips/tips_343.htm

回答No.1

mitarashi · ベストアンサー

ChooseColor APIで表示されるダイアログを、モーダル→モードレスに変更したいという意味なら、
ChooseColorにそういう選択肢は無さそうなので無理だと思います。外していたらすみません。
http://wisdom.sakura.ne.jp/system/winapi/common/common1.html

作成したカスタムカラーを保存するバージョンを回答した事があります。ご参考まで。
http://okwave.jp/qa/q8449398.html

補足

苦肉の策ですが、あるフォームをモーダル出力にしてから、
コントロール等で、ChooseColor画面を出力すれば、
モーダル画面の他は、Excel上、アクティブにする事が、
出来ないようです。

回答No.2

mitarashi

#1です。無いなら自分でこしらえてみました。xl2010で試しています。
Web Safe ColorをUserFormに表示して色を選択し、ActiveCellに着色します。
簡単なカレンダーフォームとして作ったものを改造したので、冗長な箇所があります。Indexを設定していますが、ここでは活用していなかったりします。フォームの幅の下限が決まってしまうのが寂しい...枠を表示しないと自由が利きますが、こんどは閉じる手段を考える必要が出てきたり、面倒なのでここまでにしておきます。
☆標準モジュール
Sub test()
UserForm1.Show vbModeless
End Sub

☆UserForm1モジュール
コントロールは何も置きません。サイズも自動で設定します。
Dim myClsIndex As Integer 'ラベルコントロールの番号
Dim labelArray() As LabelCtrl 'ラベルコントロールの配列

Const labelWidth As Single = 10
Const labelHeight As Single = 10

Private Sub UserForm_Initialize()
Dim colorArray As Variant
Dim i As Long, j As Long, k As Long
Dim strColor As String
Dim labelTop As Single, labelLeft As Single
Dim xFrame As Single, yFrame As Single

xFrame = Me.Width - Me.InsideWidth
yFrame = Me.Height - Me.InsideHeight
colorArray = Array("00", "33", "66", "99", "CC", "FF")
myClsIndex = 0
'ユーザーフォームの設定
With Me
.caption = "色選択"
.Width = labelWidth * UBound(colorArray) + xFrame
.Height = labelHeight * (UBound(colorArray) + 1) ^ 2 + yFrame
End With

'ラベルコントロールの配列生成
labelTop = 0
For i = 0 To UBound(colorArray)
For j = 0 To UBound(colorArray)
For k = 0 To UBound(colorArray)
strColor = colorArray(i) & colorArray(j) & colorArray(k)
labelLeft = labelWidth * k
Call addLabel(labelLeft, labelTop, CLng("&H" & strColor))
Next k
labelTop = labelTop + labelHeight
Next j
Next i

End Sub

'ラベルコントロール配列のクリックイベントで起動されるルーチン
Public Sub labelClicked(getColor As Long)
ActiveCell.Interior.Color = getColor
End Sub

'ラベルの追加
Private Function addLabel(labelLeft As Single, labelTop As Single, myColor As Long) As Integer
Dim myLabel As MSForms.Label

Set myLabel = Me.Controls.Add("Forms.Label.1", , False)
myClsIndex = myClsIndex + 1
With myLabel
.top = labelTop
.left = labelLeft
.Height = labelHeight
.Width = labelWidth
.BackColor = myColor
.visible = True
End With
ReDim Preserve labelArray(1 To myClsIndex)
Set labelArray(myClsIndex) = New LabelCtrl
Set labelArray(myClsIndex).parent = Me
labelArray(myClsIndex).S_SetLabel myLabel, myClsIndex
End Function

☆クラスモジュールLabelCtrl
Private WithEvents myLabel As MSForms.Label
Private myIndex As Integer
Private myParent As Object '親UserForm

Public Sub S_SetLabel(newLabel As MSForms.Label, index As Integer)
Set myLabel = newLabel
myIndex = index
End Sub

Private Sub myLabel_Click()
Call Me.parent.labelClicked(myLabel.BackColor)
End Sub

Public Property Get parent() As Object
Set parent = myParent
End Property

Public Property Set parent(newParent As Object)
Set myParent = newParent
End Property