[[20110526163113]]　『シェイプのチェックボックス』（たま）　ページの最後に飛ぶ

『シェイプのチェックボックス』（たま）

 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用は、投稿した覚えがあったので探しました。

[[20091111134022]]

 ↑ここの最後に提示したコードを差し替えていただければよいのですが・・・。

 一応、修正版を載せます
 新規ブックの標準モジュールに

 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("文字サイズを８～４８の範囲で指定してください", , 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さん有難うございます。とても参考になりました。
修正版もお手数お掛けして、有難うございました。

 余談：チェックボックスの画像を大きくし、チェック付とチェック無しを作りトリミングで要らない部分をカットで作れるかと思いましたが、スキルが低い為、断念

コメント返信：

[ 一覧(最新更新順) ]

[[20110526163113]] 『シェイプのチェックボックス』（たま） ページの最後に飛ぶ

[[20110526163113]]　『シェイプのチェックボックス』（たま）　ページの最後に飛ぶ