Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

6216 / 76734

←次へ　｜　前へ→


	【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

1 hits

▼

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