| |
とも さん、Jakaさん、こんばんは。
先日、同じようなご質問を受けました。
但し、その質問では、シートに配置するチェックボックスの四角の大きさを
大きくしたい ということでした。
図形を使って自作するしかないと回答しました。
標準モジュールに
'=================================================================
Option Explicit
'===============================================================
Sub mk_mycheckbox()
Dim sp1 As Shape
Dim sp2 As Shape
Dim t_sz As Variant
Dim cond As Variant
Dim rng As Range
Set rng = Selection
cond = get_mkobj_cond
If TypeName(cond) <> "Boolean" Then
With rng
Set sp1 = .Parent.Shapes.AddShape(msoShapeRectangle, .Left, .Top, Val(cond(2)), Val(cond(2)))
sp1.Fill.Solid
With sp1.TextFrame
.Characters.Text = ChrW(10003)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Characters.Font.Size = Val(cond(2))
.AutoSize = True
DoEvents
.AutoSize = False
.Characters.Text = ""
End With
Set sp2 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, sp1.Left + sp1.Width + 7.5, sp1.Top, Val(t_sz), Val(t_sz))
sp2.Fill.Solid
sp2.Line.Visible = msoFalse
With sp2.TextFrame
.Characters.Text = cond(1)
.Characters.Font.Size = Val(cond(2))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.AutoSize = True
End With
With .Parent.Shapes.Range(Array(sp1.Name, sp2.Name)).Group
.OnAction = "mycheck_Click"
Application.Range(cond(3)).Name = "L" & Replace(.Name, " ", "")
Application.Range(cond(3)).Value = False
End With
End With
End If
End Sub
'===============================================================
Function get_mkobj_cond() As Variant
Const sz = 11
Dim rng As Range
Dim cond(1 To 3) As Variant
get_mkobj_cond = False
cond(1) = Application.InputBox("チェックボックスのテキストを入力してください")
If TypeName(cond(1)) <> "Boolean" Then
cond(2) = Application.InputBox("文字サイズを１１〜４８の範囲で指定してください", , sz)
If TypeName(cond(2)) <> "Boolean" Then
If Val(cond(2)) >= 11 And Val(cond(2)) <= 48 Then
On Error Resume Next
Set rng = Application.InputBox("リンクセルを選択して下さい", , , , , , , 8)
If Err.Number = 0 Then
cond(3) = rng.Address(, , , True)
get_mkobj_cond = cond()
End If
On Error GoTo 0
End If
End If
End If
Erase cond()
End Function
'===================================================================================
Sub mycheck_Click()
Dim ref As String
Dim gnm As String
Dim shp As Shape
Dim ss As Shape
Dim nm() As Variant
Dim g0 As Long
If TypeName(Application.Caller) = "String" Then
Set shp = ActiveSheet.Shapes(Application.Caller).ParentGroup
ref = "L" & Replace(shp.Name, " ", "")
For Each ss In shp.GroupItems
ReDim Preserve nm(g0)
nm(g0) = ss.Name
g0 = g0 + 1
Next
gnm = shp.Name
shp.Ungroup
With ActiveSheet
For g0 = LBound(nm()) To UBound(nm())
With .Shapes(nm(g0))
If .Type = 1 Then
With .TextFrame.Characters
If .Text = "" Then
.Text = ChrW(10003)
Application.Range(ref).Value = True
Else
.Text = ""
Application.Range(ref).Value = False
End If
End With
Exit For
End If
End With
Next
End With
With ActiveSheet.Shapes.Range(nm()).Regroup
.Name = gnm
End With
End If
End Sub
これで適当なセルを選択した状態でmk_mycheckboxを実行してみてください。
チェックボックスのテキストの入力を促されますから、
仮に「Ｅｘｃｅｌ ＶＢＡ質問箱」（両端の「」は除く）と指定してＯＫボタンを
クリックしてください。
次に文字のサイズの入力を促されますから、11から48の間で指定してＯＫボタンを
クリックしてください。
（例 36）
チェックの有無をリンクするセルを選択してください。
文字サイズに応じたチェックボックスが作成されます。
作成されたチェックボックスをクリックしてみてください。
チェックが付いたり消えたりします。
と回答しました。
試してみてください。
尚、チェックボックスがユーザーフォーム配置の場合は、
ラベルを使って似たようなことをしなけれななりませんが・・・。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
