Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


1135 / 13645 ツリー ←次へ | 前へ→

【76096】シート上の図形の再描写 ど素人 14/9/24(水) 13:06 質問[未読]
【76098】Re:シート上の図形の再描写 独覚 14/9/24(水) 14:30 発言[未読]
【76101】Re:シート上の図形の再描写 ど素人 14/9/25(木) 15:27 発言[未読]
【76102】Re:シート上の図形の再描写 独覚 14/9/25(木) 16:14 発言[未読]
【76099】Re:シート上の図形の再描写 独覚 14/9/24(水) 16:45 発言[未読]
【76120】Re:シート上の図形の再描写 ど素人 14/9/30(火) 14:40 お礼[未読]

【76096】シート上の図形の再描写
質問  ど素人  - 14/9/24(水) 13:06 -

引用なし
パスワード
   環境 excel 2013

 現在シート上に作成された図形や矢印などを取り込み、コピーではなく再描写させるプログラムを作成しております。

 しかし作成したのプログラムでは把握している範囲で次のような問題があります。
  ・矢印の向きが再現されない
  ・矢印の太さが設定していないにもかかわらず太くなることがある。
  ・曲線矢印が直線になってしまう
  ・円が描写されない
  ・グループ化されている場合、グループ化を手動で解除しなければ正しく取り込まれない
  
 これらを解決するにはどのようにしたらよいか、ご教授いただけないでしょうか?
 よろしくお願いいたします。


以下作成したプログラム

Sub 要素書き出し3_Case()

  Dim 要素数 As Integer
  Dim 中身 As Variant
  Dim left As Double
  Dim top As Double
  Dim width As Double
  Dim Height As String
  Dim obj As String
 

  要素数 = 1
    For Each 中身 In ActiveSheet.Shapes


      '--------------------プロパティー表示-----------------------'
         Cells(要素数 + 2, 1) = 中身.Name
         Cells(要素数 + 2, 2).Value = 中身.AutoShapeType

  
      Select Case True
'==================コネクター================================================================
  
           Case 中身.Connector
        '--------------------プロパティー取得-----------------------'
            obj = 中身.Type
            left = 中身.left
            top = 中身.top
            width = 中身.width + 中身.left
            Height = 中身.Height + 中身.top


             If 中身.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
              
                  Cells(要素数 + 2, 7) = "msoArrowheadTriangle"
               End If
               
             If 中身.Line.EndArrowheadStyle = msoArrowheadTriangle Then
              
                  Cells(要素数 + 2, 8) = "msoArrowheadTriangle"
               End If
           '--------------------図形書きだし-----------------------'
         
               ActiveSheet.Shapes.AddConnector(left, top, width, Height).Select
           
    
             If 中身.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
                 Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadTriangle
               End If
    
             If 中身.Line.EndArrowheadStyle = msoArrowheadTriangle Then
                 Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
               End If

'================円============================================================================


'================その他========================================================================

         
            Case Else
            '--------------------プロパティー取得-----------------------'
                obj = 中身.Type
                left = 中身.left
                top = 中身.top
                width = 中身.width
                Height = 中身.Height
                
            '--------------------図形書きだし-----------------------'
            ActiveSheet.Shapes.AddShape(obj, left, top, width, Height).Select
                Selection.ShapeRange.Name = "test 図形" & 要素数


         End Select
  
  '--------------------プロパティー表示----------------------'
      Cells(要素数 + 2, 2).Value = obj
      Cells(要素数 + 2, 3).Value = left
      Cells(要素数 + 2, 4).Value = top
      Cells(要素数 + 2, 5).Value = width
      Cells(要素数 + 2, 6).Value = Height
     
      要素数 = 要素数 + 1
          
    Next


End Sub

【76098】Re:シート上の図形の再描写
発言  独覚  - 14/9/24(水) 14:30 -

引用なし
パスワード
   ▼ど素人 さん:
>環境 excel 2013
私の環境は2010なので異なっていることがあるかもしれません。
で、
>・矢印の向きが再現されない
これについてだけ。

まず、
>ActiveSheet.Shapes.AddConnector(left, top, width, Height).Select

>ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height).Select
のミスでしょうか?
2013でobj省略可能になったのかとも思いましたが

ht tp://msdn.microsoft.com/ja-jp/library/office/ff834664(v=office.15).aspx
では必須項目のようですが。

で、本題です。
その矢印は本当に「msoArrowheadTriangle」(三角矢印)でしょうか?
私のところでは何もしない状態では矢印は「msoArrowheadOpen」(開いた矢印)でした。

矢印にも種類があるので
>ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height).Select
>If 中身.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
>  Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadTriangle
> End If
>If 中身.Line.EndArrowheadStyle = msoArrowheadTriangle Then
>  Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
>End If
部分を
>  Dim wk_中身 As Variant
を追加したうえで
>Set wk_中身 = ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height)
>wk_中身.Line.BeginArrowheadStyle = 中身.Line.BeginArrowheadStyle
>wk_中身.Line.EndArrowheadStyle = 中身.Line.EndArrowheadStyle
としてはどうでしょうか?

【76099】Re:シート上の図形の再描写
発言  独覚  - 14/9/24(水) 16:45 -

引用なし
パスワード
   ▼ど素人 さん:
補足です。
線の太さや線の種類、矢印の大きさなど、ヘルプで対応するプロパティを調べて先に
示したのと同じ方法で値を入れてはどうでしょうか?

【76101】Re:シート上の図形の再描写
発言  ど素人  - 14/9/25(木) 15:27 -

引用なし
パスワード
   ▼独覚 さん:

返信して下さりありがとうございます。
>まず、
>>ActiveSheet.Shapes.AddConnector(left, top, width, Height).Select
>は
>>ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height).Select
>のミスでしょうか?

ミスです。抜けてしまったようです。申し訳ございません。


>矢印にも種類があるので
 取り込む図形をおおよそ持っており、矢印については三角矢印だけでしたのでこうしてしまいました。
おっしゃると通りに書き換えると確かに矢印の形は反映されました。

しかし矢印1本でテストした際、2本描かれるようになってしまい、調べたところ
>>Set wk_中身 = ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height)
で1本目

>>wk_中身.Line.BeginArrowheadStyle = 中身.Line.BeginArrowheadStyle
で2本目が描かれ

>>wk_中身.Line.EndArrowheadStyle = 中身.Line.EndArrowheadStyle
がどうやら2本目に対して実行されているようです。

 また
←ーーーーー● (右側が始点)
と描いていたものが

描かれる矢印の2本目で
●ーーーーー→
となってしまいます。
 これらの解決方法をいろいろと探ってみたのですが見つけることができませんでした。
もしご存知でしたら教えてくださると大変助かります。

よろしくお願いいたします。

以下にソースコードを示します。

Sub 要素書き出し3_Case()

  Dim 要素数 As Integer
  Dim 中身 As Variant
  Dim left As String
  Dim top As String
  Dim width As String
  Dim Height As String
  Dim obj As String
 

  要素数 = 1
    For Each 中身 In ActiveSheet.Shapes


      '--------------------プロパティー表示-----------------------'
         Cells(要素数 + 2, 1) = 中身.Name
         Cells(要素数 + 2, 2).Value = 中身.AutoShapeType

  
      Select Case True
'==================コネクター================================================================
  
           Case 中身.Connector
        '--------------------プロパティー取得-----------------------'
            obj = 中身.Type
            left = 中身.left
            top = 中身.top
            width = 中身.width + 中身.left
            Height = 中身.Height + 中身.top


             If 中身.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
              
                  Cells(要素数 + 2, 7) = "msoArrowheadTriangle"
               End If
               
             If 中身.Line.EndArrowheadStyle = msoArrowheadTriangle Then
              
                  Cells(要素数 + 2, 8) = "msoArrowheadTriangle"
               End If
           '--------------------図形書きだし-----------------------'
         
               ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height).Select


'-----------変更箇所----------          
                  Dim wk_中身 As Variant
                  
                    Set wk_中身 = ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height)

                      wk_中身.Line.BeginArrowheadStyle _
                       = 中身.Line.BeginArrowheadStyle

                      wk_中身.Line.EndArrowheadStyle _
                       = 中身.Line.EndArrowheadStyle


'----------変更箇所終わり-------
'================円============================================================================


'================その他========================================================================

         
            Case Else
            '--------------------プロパティー取得-----------------------'
                obj = 中身.Type
                left = 中身.left
                top = 中身.top
                width = 中身.width
                Height = 中身.Height


         End Select
  
  '--------------------プロパティー表示----------------------'
      Cells(要素数 + 2, 2).Value = obj
      Cells(要素数 + 2, 3).Value = left
      Cells(要素数 + 2, 4).Value = top
      Cells(要素数 + 2, 5).Value = width
      Cells(要素数 + 2, 6).Value = Height
     
      要素数 = 要素数 + 1
          
    Next


End Sub

【76102】Re:シート上の図形の再描写
発言  独覚  - 14/9/25(木) 16:14 -

引用なし
パスワード
   ▼ど素人 さん:
>しかし矢印1本でテストした際、2本描かれるようになってしまい、調べたところ
>>>Set wk_中身 = ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height)
>で1本目
>
>>>wk_中身.Line.BeginArrowheadStyle = 中身.Line.BeginArrowheadStyle
>で2本目が描かれ
>
>>>wk_中身.Line.EndArrowheadStyle = 中身.Line.EndArrowheadStyle
>がどうやら2本目に対して実行されているようです。

これに関しては
>>ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height).Select
>>If 中身.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
>>  Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadTriangle
>> End If
>>If 中身.Line.EndArrowheadStyle = msoArrowheadTriangle Then
>>  Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
>>End If
>部分を
>>  Dim wk_中身 As Variant
>を追加したうえで
>>Set wk_中身 = ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height)
>>wk_中身.Line.BeginArrowheadStyle = 中身.Line.BeginArrowheadStyle
>>wk_中身.Line.EndArrowheadStyle = 中身.Line.EndArrowheadStyle
>としてはどうでしょうか?
で、置き換え前に含めて、置き換え後に無くすことで
>ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height).Select
を削除することを示したつもりでした。
なので
>ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height).Select
を削除してください。

あと、向きに関してはこちらでもわからず、さらに矢印が斜めになっている場合
右下へ向かう矢印だとそのまま再描画できますが右上へ向かう矢印だと
右下へ向かう矢印として描画してしまうようです。

で、いくつか試してみて
ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height)
部分で「left」が開始X座標、topが開始Y座標、widthが終了X座標、heightが
終了Y座標になるためleftよりwidthが大きければ右向き、leftがwidthより
大きければ左向きの矢印に、topとheightも同じようになるようです。

けれども既に入力されている図形から始点座標、終点座標を求める方法は
わかりませんでした。
(現在のプログラムでは始点・終点ではなく左上、右下の座標を求めているため
向きが逆になったりしてるようです)

お役にたてなくてすみません。

【76120】Re:シート上の図形の再描写
お礼  ど素人  - 14/9/30(火) 14:40 -

引用なし
パスワード
   ▼独覚 さん:
返信が遅くなってしまいすいません。
回答して下さりありがとうございました。 
引き続き作成していきます。

その後、いったん始点で矢印を出したりして変化させ、変化したX座標を取得すればbeginXを取得できるのではないかと思い調べましたが見つけられませんでした。


一応太さについては修正したものを貼っときます。

Sub 要素書き出し3_Case()

  Dim 要素数 As Integer
  Dim 中身 As Variant
  Dim left As String
  Dim top As String
  Dim width As String
  Dim Height As String
  Dim obj As String
  Dim line_weight As Variant

  要素数 = 1
    For Each 中身 In ActiveSheet.Shapes


      '--------------------プロパティー表示-----------------------'
         Cells(要素数 + 2, 1) = 中身.Name
         Cells(要素数 + 2, 2) = 中身.AutoShapeType
         
  
      Select Case True
'==================コネクター================================================================
  
           Case 中身.Connector
           
            
        '--------------------プロパティー取得-----------------------'
              obj = 中身.Type
              left = 中身.left
              top = 中身.top
              width = 中身.width + 中身.left
              Height = 中身.Height + 中身.top
              line_weight = 中身.Line.Weight
     '--------------------プロパティー表示----------------------'
               Cells(要素数 + 2, 7) = 中身.Line.Weight
               
                
               If 中身.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
                
                    Cells(要素数 + 2, 8) = "msoArrowheadTriangle"
                 End If
                 
               If 中身.Line.EndArrowheadStyle = msoArrowheadTriangle Then
                
                    Cells(要素数 + 2, 9) = "msoArrowheadTriangle"
                 End If
             '--------------------図形書きだし-----------------------'

                 ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height).Select
                   Selection.ShapeRange.Name = "test 図形" & 要素数
                 Selection.ShapeRange.Line.Weight = line_weight
 Dim wk_中身 As Variant
                  
                    Set wk_中身 = ActiveSheet.Shapes.AddConnector(obj, left, top, width, Height)
                       wk_中身.Line.BeginArrowheadStyle _
                       = 中身.Line.BeginArrowheadStyle
                       wk_中身.Line.EndArrowheadStyle _
                       = 中身.Line.EndArrowheadStyle


'================円============================================================================


'================その他========================================================================

         
            Case Else
            '--------------------プロパティー取得-----------------------'
                obj = 中身.Type
                left = 中身.left
                top = 中身.top
                width = 中身.width
                Height = 中身.Height
                line_weight = 中身.Line.Weight
            ' --------------------図形書きだし-----------------------'
            ActiveSheet.Shapes.AddShape(obj, left, top, width, Height).Select
                Selection.ShapeRange.Name = "test 図形" & 要素数
            '    Selection.ShapeRange.Line.Weight = line_weight 何故かエラー多発のためコメントアウト


         End Select
  
  '--------------------プロパティー表示----------------------'
      Cells(要素数 + 2, 2).Value = obj
      Cells(要素数 + 2, 3).Value = left
      Cells(要素数 + 2, 4).Value = top
      Cells(要素数 + 2, 5).Value = width
      Cells(要素数 + 2, 6).Value = Height
      Cells(要素数 + 2, 7).Value = line_weight
      要素数 = 要素数 + 1
          
    Next
   
End Sub

1135 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free