[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『シェイプのチェックボックス』(たま)
Excel2003及びExcel2000で使いたいですが [[20080908154905]]のichinoseさんのを使用して Excel2000だとエラーになってしまいます。 Set shp = ActiveSheet.Shapes(Application.Caller).ParentGroupでエラーとなり Set shp = ActiveSheet.Shapes(Application.Caller) ActiveSheet.Shapes.Range(nm()).Regroup.OnAction = "mycheck_Click"を追加 とすると作動していますが、 2003では、当たり前ですがエラーとなります。Excelのバージョンでコードを分岐するぐらいしか思いつきませんが、何か他の方法は有りますでしょうか?
>2003では、当たり前ですがエラーとなります。 環境がないので確認できませんが、エラー箇所を提示してください。
以前、Excel2000用は、投稿した覚えがあったので探しました。
↑ここの最後に提示したコードを差し替えていただければよいのですが・・・。
一応、修正版を載せます 新規ブックの標準モジュールに
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 On Error Resume Next 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)) .Characters.Font.ColorIndex = cond(4) .Characters.Font.Bold = cond(5) .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)) .Characters.Font.ColorIndex = cond(4) .Characters.Font.Bold = cond(5) .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 On Error GoTo 0 End Sub '=============================================================== Function get_mkobj_cond() As Variant Const sz = 11 Dim ans As Long Dim rng As Range Dim cond(1 To 5) As Variant get_mkobj_cond = False cond(1) = Application.InputBox("チェックボックスのテキストを入力してください") If TypeName(cond(1)) <> "Boolean" Then cond(2) = Application.InputBox("文字サイズを8〜48の範囲で指定してください", , sz) If TypeName(cond(2)) <> "Boolean" Then If Val(cond(2)) >= 8 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) cond(4) = Application.InputBox("文字及び、チェックの色をパレット番号で指定して下さい") If IsNumeric(cond(4)) Then ans = MsgBox("太字にしますか?", vbYesNoCancel) If ans <> vbCancel Then If ans = vbYes Then cond(5) = True Else cond(5) = False End If get_mkobj_cond = cond() End If End If
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 Object Dim shpg As Object Dim ss As Shape Dim nm() As Variant Dim g0 As Long On Error Resume Next If TypeName(Application.Caller) = "String" Then Set shp = ActiveSheet.Shapes(Application.Caller) Set shpg = shp.GroupItems If Err.Number <> 0 Then Set shp = shp.ParentGroup Set shpg = shp.GroupItems End If ref = "L" & Replace(shp.Name, " ", "") For Each ss In shpg 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 .OnAction = "mycheck_Click" End With End If On Error GoTo 0 End Sub
これだと Excel2000で作成しても Excel2002で作成しても正常にチェックがON OFFになります。
留意点
上記コードでは、Excel2000で作成したチェックボックスは、Excel2000でもExcel2002でも 作動します。 が、Excel2002で作成したチェックボックスは、Excel2002では、もちろん作動しますが、 Excel2000では、作動しません。
二つのバージョンで作動させたい場合は、下位バージョンでチェックボックスを 作成してください。
これは、Excel2000とExcel2002の場合ですが、Excel2003ではどこかでエラーになりますか? 正常に作動しない場合、mycheck_Click内の on error resume next をコメント化して、エラーの発生箇所を特定してください。
ichinose
(たま)です。 Excel2000 Set shp = ActiveSheet.Shapes(Application.Caller).ParentGroupでエラーとなりその部分を Set shp = ActiveSheet.Shapes(Application.Caller)とすると shp.name グループ名 Excel2003の場合 Set shp = ActiveSheet.Shapes(Application.Caller)とすると shp.name テキストボックス名となり For Each ss In shp.GroupItemsここでエラー shp.GroupItemsグループじゃないとExcelに怒られてしまいました。2003では、当たり前ですがエラーとなりますと思った部分です。[[20080908154905]]は、2003作動します。
Set shpg = shp.GroupItemsで判断(If Err.Number <> 0 Then)のエラーは、教えていただき、なるほど と、考えがありませんでした。Application.Versionで判断しか思いつきませんでした。 ichinoseさん有難うございます。とても参考になりました。 修正版もお手数お掛けして、有難うございました。
余談:チェックボックスの画像を大きくし、チェック付とチェック無しを作りトリミングで要らない部分をカットで作れるかと思いましたが、スキルが低い為、断念
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.