Sub AddShape() Dim shpObj Dim n ' テストデータ n = 5 Dim strArray() ReDim strArray(n - 1) strArray(0) = "Message1" strArray(1) = "Message2" strArray(2) = "Message3" strArray(3) = "Message4" strArray(4) = "Message5" Dim i For i = 0 To n - 1 ' DrawRectangle により四角形を描画します ' パラメータは x1, y1, x2, y2 (単位:インチ) Set shpObj = ActivePage.DrawRectangle(0, i, 1, i + 1) ' シェイプオブジェクトに文字列を設定 shpObj.Text = strArray(i) Next End Sub
Sub AddShapeFromExcel() Dim strFileName Dim strSheetName strFileName = "D:\home\edu\hatena\visio_vba\test.xls" ' テストデータ strSheetName = "SampleSheet" ' シート名 ' ADO を利用して Excel ファイルをオープンする Dim cn Set cn = CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFileName & ";Extended Properties=Excel 8.0" ' ADO を利用して Excel のシートのデータをレコードセットにセットする Dim rs Set rs = cn.Execute("SELECT * FROM [Excel 8.0;database=" & strFileName & "].[" & strSheetName & "$]") Dim shpObj ' レコード件数分ループする While Not rs.BOF And Not rs.EOF ' 四角形を作成する Set shpObj = ActivePage.DrawRectangle(0, 0, 1, 1) ' 四角形にテキストデータを挿入する shpObj.Text = rs(0) '次のレコードに移動する rs.MoveNext Wend End Sub