Excel VBA質問箱 IV

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

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


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

8821 / 76732

←次へ　｜　前へ→


	【73479】Re:オートシェイプのプロパティの種類と値をセルに書き出す

UO3 - 13/1/14(月) 20:55 -


	引用なし

	パスワード

▼すが分さん：

こんばんは

その昔、上で申し上げたようなことで、ある程度シェープの階層を把握した時に
その理解が正しいかどうかを確かめるコードを書いたことがあります。

Sheet1 に　思いつくシェープ配置。テキストやキャプションがセットできるものについては
それらもセット。
（図や図形、フォームツールコントロールやコントロールツールボックスのコントロール、
　さらには　入力規則　の▼　等々）

これらシェープをSheet2にリストアップします。
2003時代に作ったものですから当然2007以降にでてきたものは対象外です。

なお、別のシートに以下のそれぞれ2列のテーブルを記述しておいて、それら領域に
"msoList"　と　"FCList"　という名前をつけておきます。

「msoList」

1　　　　msoAutoShape
2　　　　msoCallout
3　　　　msoChart
4　　　　msoComment
5　　　　msoFreeform
6　　　　msoGroup
7　　　　msoEmbeddedOLEObject
8　　　　msoFormControl
9　　　　msoLine
10　　　　msoLinkedOLEObject
11　　　　msoLinkedPicture
12　　　　msoOLEControlObject
13　　　　msoPicture
14　　　　msoPlaceholder
15　　　　msoTextEffect
16　　　　msoMedia
17　　　　msoTextBox
18　　　　msoScriptAnchor
19　　　　msoTable
20　　　　msoCanvas
21　　　　msoDiagram
22　　　　msoInk
23　　　　msoInkComment

「FCList」

0　　　　xlButtonControl
1　　　　xlCheckBox
2　　　　xlDropDown
3　　　　xlEditBox
4　　　　xlGroupBox
5　　　　xlLabel
6　　　　xlListBox
7　　　　xlOptionButton
8　　　　xlScrollBar
9　　　　xlSpinner

以下、コードです。

Option Explicit

Enum ReportItems
　 RIDummyS
　 objName
　 objtypen
　 objType
　 objTypename
　 objCaption
　 objValue
　 objProgid
　 RIDummyZ
End Enum
　
Sub Sample()
　　Dim obj As Shape
　　Dim i As Long
　　Dim ctr As Long
　　Dim v(1 To RIDummyZ - 1)
　　Dim ListSh As Worksheet
　　
　　Set ListSh = Sheets("Sheet2")
　　With ListSh
　　　　.Cells.ClearContents
　　　　.Range("A1:G1").Value = Split("オンジェクト名 Type(MsoShapeType) Type TypeName Caption Value PtogID/FormControlType")
　　End With
　　
　　ctr = 1
　　
　　For Each obj In Sheets("Sheet1").Shapes
　　
　　　　For i = LBound(v) To UBound(v)
　　　　　 v(i) = "#N/A"
　　　　Next
　　　　
　　　　On Error Resume Next
　　　　v(objName) = obj.Name
　　　　v(objtypen) = Application.VLookup(obj.Type, Range("msoList"), 2, False)
　　　　v(objType) = obj.Type
　　　　v(objTypename) = TypeName(obj.DrawingObject)
　　　　If obj.Type = 12 Then 'OLEObject
　　　　　 v(objCaption) = obj.DrawingObject.Object.Caption
　　　　　 v(objValue) = obj.DrawingObject.Object.Value
　　　　　 v(objProgid) = obj.DrawingObject.progID
　　　　Else
　　　　　 v(objCaption) = obj.DrawingObject.Caption
　　　　　 v(objValue) = obj.DrawingObject.Value
　　　　　 v(objProgid) = Application.VLookup(obj.FormControlType, Range("FCList"), 2, False)
　　　　End If
　　　　
　　　　On Error GoTo 0
　　　　
　　　　ctr = ctr + 1
　　　　ListSh.Cells(ctr, 1).Resize(, UBound(v)).Value = v
　　　　
　　Next
　　
　　ListSh.Range("A1").CurrentRegion.Columns.AutoFit
　　
End Sub

569 hits

▼

【73471】オートシェイプのプロパティの種類と値をセルに書き出す すが分 13/1/14(月) 10:33