ITservice雄飛 プロモーションビデオ

2020年7月31日金曜日

ExcelVBAでShapes(画像)が所属するセルのRowを取得する

ITservice雄飛です。

ほんとにお久しぶりの投稿です。
今回は、Excel VBAを。

今、オブジェクト(シート上に貼り付けられた画像)のRowsを取得する関数を探していたんですが。

どうも、昔はあった様だけれども、現在は廃止になっている様で、無情にエラーが返って終了しました。

色々考えた末、セルのサイズも取得できること考えたら、それアルゴリズムに落とせば良いだけじゃん、、、という、一般的且つ、ごく普通の考えに至りました。

で、思いついたら即実装。
簡単ですね、WhileとIFと変数の加算減算だけなので。
例ではRowですが、取得する値を幾つか変えれば、Colにも対応可能ですね。

本番はLazarus(Pascal)からComObjで呼び出すので、これからそれを組みますが。

まぁ、消すには勿体ないので、ブログ記事にしました。
以下、こんな感じ、即興のテスト関数です。

※このサンプル関数では事前に、オブジェクト(Shapes)を選択(Select)している必要があります。


Function Return_Sharp_Rows(start_i As Long, end_i As Long) As Long

  Dim tp As Long '選択したオブジェクトのTop座標を格納
  Dim rw As Long 'RowsのTopの合計値を格納
  Dim rw2 As Long 'RowsのHeightの合計値を格納
  Dim i_1 As Long 'While開始位置
  Dim i_2 As Long 'While終了位置
  
  tp = Selection.ShapeRange.Top '選択されたオブジェクトのTop座標を取得
  rw = 0 'Row.Topsを初期化
  rw2 = 0 'Row.Heightsを初期化
  i_1 = start_i '開始位置を引数から代入
  i_2 = end_i '終了位置を引数から代入
  Return_Sharp_Rows = -1 '検索にヒットしなかった場合の暫定値設定
  While i_1 < i_2 'While文開始
   rw = rw + Cells(i_1, 1).Top  'Row.Topsを代入
   rw2 = rw2 + Cells(i_1, 1).Height  'Row.Heightsを代入
   If ((rw <= tp) And (rw2 >= tp)) Or (rw = tp) Then 'オブジェクトの座標をセルの数値と比較し検証する
     Return_Sharp_Rows = i_1 '一致した場合、戻り値にセルのRow(i_1)を代入
     i_2 = i_1 '開始位置と終了位置を同一にし、While文を終了させる
   End If
   i_1 = i_1 + 1 'Rowを一つ下に移す(i_1を加算する)
  Wend
End Function

呼び出すときはこうします。例です。
Sub Get_Shapes_CellRow()
 Dim i As Integer
 i = Return_Sharp_Rows(1, 20)
 MsgBox Str(i)
End Sub

以上。
Excelって便利ですね。

0 件のコメント:

コメントを投稿