|
|
|
2017.12.30
カテゴリ：マクロ
'---------------------------------------------------------------------- 'メインプログラム呼び出し '---------------------------------------------------------------------- Sub a_call() '---------------------------------------------------------------------- 'ファイル名とシート名を入力 '---------------------------------------------------------------------- Dim bookName As String Dim sheetName As String bookName = "あああ.xlsx" sheetName = "Sheet1" '---------------------------------------------------------------------- '呼び出して､エクセルシートへ代入 '---------------------------------------------------------------------- Workbooks("あああ.xlsx").Worksheets("Sheet2").Range("A1:BYE10000") = get_Shapes_Property(bookName, sheetName) '---------------------------------------------------------------------- '完了のメッセージ '---------------------------------------------------------------------- MsgBox "END" End Sub '以下、メイン↓↓↓↓ '---------------------------------------------------------------------- '概要=ファイル名とシート名をもとに図形一覧を取得する '引数=ファイル名＋シート名 '戻値=図形のプロパティ一覧（バリアント型） '備考=格納する配列は動的 '↓呼び出し元サンプル↓ '---------------------------------------------------------------------- 'Sub a_call() 'Dim bookName As String 'Dim sheetName As String 'bookName = "あああ.xlsx" 'sheetName = "Sheet1" 'Workbooks("あああ.xlsx").Worksheets("Sheet2").Range("A1:BYE10000") = get_Shapes_Property(bookName, sheetName) 'MsgBox "END" 'End Sub '---------------------------------------------------------------------- Public Function get_Shapes_Property(bookName As String, sheetName As String) As Variant Dim obj As Object Dim lists() As String '---------------------------------------------------------------------- 'ヘッダ部分(汎用性確保のため省略) '---------------------------------------------------------- 'ReDim Preserve lists(12, 0) As String 'lists(0, 0) = "Book" 'lists(1, 0) = "Sheet" 'lists(2, 0) = "AutoShapeType" 'lists(3, 0) = "vlookup" 'lists(4, 0) = "Text" 'lists(5, 0) = "Left" 'lists(6, 0) = "Top" 'lists(7, 0) = "Width" 'lists(8, 0) = "Height" 'lists(9, 0) = "TopLeftCell.Address" 'lists(10, 0) = "BottomRightCell.Address" 'lists(11, 0) = "Fill.ForeColor" 'lists(12, 0) = "color" ''---------------------------------------------------------- 'listsの行数（ループ回数）をカウントする変数 '---------------------------------------------------------------------- Dim cnt cnt = 0 '---------------------------------------------------------------------- 'シート内の全ての図形の情報を取得してlistsに格納 '---------------------------------------------------------------------- For Each obj In Workbooks(bookName).Sheets(sheetName).Shapes ReDim Preserve lists(12, cnt) As String On Error Resume Next lists(0, cnt) = Workbooks(bookName).Name lists(1, cnt) = Workbooks(bookName).Worksheets(sheetName).Name lists(2, cnt) = CStr(obj.AutoShapeType) 'lists(3, cnt)=Vlookup検索列 lists(4, cnt) = obj.TextFrame.Characters.Text lists(5, cnt) = CStr(obj.Left) lists(6, cnt) = CStr(obj.Top) lists(7, cnt) = CStr(obj.Width) lists(8, cnt) = CStr(obj.Height) lists(9, cnt) = CStr(obj.TopLeftCell.Address(False, False)) lists(10, cnt) = CStr(obj.BottomRightCell.Address(False, False)) lists(11, cnt) = CStr(obj.Fill.ForeColor) 'lists(12, cnt)=前列のRGB値で塗りつぶし cnt = cnt + 1 Next '---------------------------------------------------------------------- 'listsをget_Shapes_Propertyに代入 '---------------------------------------------------------------------- get_Shapes_Property = lists '---------------------------------------------------------------------- End Function お気に入りの記事を「いいね！」で応援しよう
最終更新日
2017.12.31 22:48:54
コメント(0) | コメントを書く
[マクロ] カテゴリの最新記事
|
