id:pochi1234
ポイントあり100ptベストアンサーあり
コンピュータ

エクセルVBAについて質問です。良回答者にはポイントはずみます。

写真のセンタリング方法についてですが、4列1行に写真を貼りたいです。
Range("A1:D4"), Range("E1:H4"), ...省略

センタリングの計算方法について、Range("A1:D4")の中心に合わせる計算方法を
教えて下さい。よろしくお願いします。

strFileName = Dir(strFilePath & "*.jpg")
Do
Set rngPicture = ActiveSheet.Range(ActiveSheet.Range("H21").Offset(j, i).Address)

Set shapePicture = ActiveSheet.Shapes.addPicture( _
Filename:=strFilePath & strFileName, LinkToFile:=False, SaveWithDocument:=True, _
Left:=Selection.Left, Top:=Selection.Top, Width:=0, Height:=0)

With shapePicture
.ScaleHeight 0.5, msoTrue
.ScaleWidth 0.5, msoTrue
　　　　　　'下記は数値を足して無理やりセンタリングしています。
.Left = rngPicture.Left + 3
.Top = rngPicture.Top + 3
End With
　　　　i = i + 4
strFileName = Dir()
Loop While strFileName <> ""

回答の条件
  • 1人5回まで
  • 登録：
  • 終了：2011/11/27 21:27:55
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:windofjuly No.1

回答回数2625ベストアンサー獲得回数1149

ポイント100pt

関数にしてみました

Sub MyPicList(ByVal picFilename As String, ByVal cellRange As String)
    Dim x, y, w, h As Double
    Dim x2, y2 As Double
    
    ' セル範囲の左上座標（x,y）と
    ' セル範囲の高さと幅（h,w）は次のようなプロパティで得る
    With Range(cellRange)
        x = .Left
        y = .Top
        w = .Width
        h = .Height
    End With
    '中心座標（x2,y2）を計算する
    x2 = x + w / 2
    y2 = y + h / 2
    '画像は左上基準
    '画像サイズから左上座標を計算して配置する
    With ActiveSheet.Pictures.Insert(picFilename)
        .Left = x2 - .Width / 2
        .Top = y2 - .Height / 2
    End With
End Sub

上記関数の呼び出し例

Sub Macro21()
    'ファイル名、貼り付け範囲
    Call MyPicList("ファイル名", "E1:H4")
    Call MyPicList("ファイル名", "D10:D13")
End Sub

以下はテストしてませんが、多分お望みのとおりだと思います

Sub Macro22()
    Dim strFileName As String
    Dim i As Long
    
    strFileName = Dir(strFilePath & "*.jpg")
    i = 1
    Do While strFileName <> ""
        Call MyPicList(strFileName, "E" & i & ":H" & (i + 3))
        i = i + 1
        strFileName = Dir()
    Loop
End Sub
id:pochi1234

ご回答ありがとうございます。
まだ動作チェックはしていませんが、希望通りの回答だと思います。

ポイント送信すればいいという問題ではなかったです。申し訳ありません。
今後はこういうことがないようにします。
感謝しています。

2011/11/27 21:26:50

その他の回答（1件）

id:windofjuly No.1

回答回数2625ベストアンサー獲得回数1149ここでベストアンサー

ポイント100pt

関数にしてみました

Sub MyPicList(ByVal picFilename As String, ByVal cellRange As String)
    Dim x, y, w, h As Double
    Dim x2, y2 As Double
    
    ' セル範囲の左上座標（x,y）と
    ' セル範囲の高さと幅（h,w）は次のようなプロパティで得る
    With Range(cellRange)
        x = .Left
        y = .Top
        w = .Width
        h = .Height
    End With
    '中心座標（x2,y2）を計算する
    x2 = x + w / 2
    y2 = y + h / 2
    '画像は左上基準
    '画像サイズから左上座標を計算して配置する
    With ActiveSheet.Pictures.Insert(picFilename)
        .Left = x2 - .Width / 2
        .Top = y2 - .Height / 2
    End With
End Sub

上記関数の呼び出し例

Sub Macro21()
    'ファイル名、貼り付け範囲
    Call MyPicList("ファイル名", "E1:H4")
    Call MyPicList("ファイル名", "D10:D13")
End Sub

以下はテストしてませんが、多分お望みのとおりだと思います

Sub Macro22()
    Dim strFileName As String
    Dim i As Long
    
    strFileName = Dir(strFilePath & "*.jpg")
    i = 1
    Do While strFileName <> ""
        Call MyPicList(strFileName, "E" & i & ":H" & (i + 3))
        i = i + 1
        strFileName = Dir()
    Loop
End Sub
id:pochi1234

ご回答ありがとうございます。
まだ動作チェックはしていませんが、希望通りの回答だと思います。

ポイント送信すればいいという問題ではなかったです。申し訳ありません。
今後はこういうことがないようにします。
感謝しています。

2011/11/27 21:26:50
id:taknt No.2

回答回数13539ベストアンサー獲得回数1198 

Sub test()
    strFileName = Dir(strFilePath & "*.jpg")
    i = 1
    Do
        
        a = 1
        
        Set shapePicture = ActiveSheet.Shapes.AddPicture( _
        Filename:=strFilePath & strFileName, LinkToFile:=False, SaveWithDocument:=True, _
        Left:=Cells(1, i).Left, Top:=Cells(1, i).Top, Width:=0, Height:=0)
        
        With shapePicture
            .ScaleHeight 0.5, msoTrue
            .ScaleWidth 0.5, msoTrue
            .Left = Cells(1, i).Left + (Range(Cells(1, i), Cells(1, i + 3)).Width - .Width) / 2
        End With
        i = i + 4
        strFileName = Dir()
    Loop While strFileName <> ""
End Sub

質問と趣旨が違う場合は、どこがどのように違うのかを 教えてください。

他2件のコメントを見る
id:pochi1234

結合セルではない範囲にということです
結合セルだとoffsetしたときにずれるのでできませんでした。

2011/11/27 21:57:30
id:taknt

offsetは してません。

2011/11/27 22:14:50

コメント（6件)

  • id:windofjuly
    うぃんど 2011/11/27 18:52:18
    Rangeのデバッグ出力の件、追記しておきましたけど、まだ未確認？
    あちらのように、こちらも後だしされそうな気がして・・・
    「ポイントあげるから寄っといで」みたいな書き出しにもちょっとね・・・

    さて、本題のほうですが、
    画面上の調整はある程度可能です
    だけど、
    印刷したりすればズレる場合が多いです
    （プリンタドライバとの兼ね合いなので、汎用的なものは作れない）

    それでも、、、概要だけでも知りたいということであれば、
    情報取得方法と計算方法の概要を書きますけど・・・？
  • id:pochi1234
    pochi1234 2011/11/27 19:20:01
    いつもご回答頂きありがとうございます。デバック出力の件ですが、
    良回答ですのでベストアンサーに致しました。
    ポイントは別途送信させて頂いています。
    返信が遅れ、不愉快な気持ちにさせてしまい申し訳ありませんでした。

    今回の件について、概要を教えて頂けませんでしょうか？
  • id:windofjuly
    うぃんど 2011/11/27 20:34:22
    あの程度の回答なので、ポイントはあのままでいいですよ
    お返ししましたので、後ほど確認してください
  • id:taknt
    きゃづみぃ 2011/11/27 21:43:50
    ベストアンサーの回答の内容が 望んでたものなんですね。

    難しい・・・www

  • id:pochi1234
    pochi1234 2011/11/27 22:00:42
    windofjulyさん、takntさんにはご迷惑をおかけして申し訳ありませんでした。

    今回の質問はShapeの中心位置を求めてそこにShapeをセットする計算方法の概要を
    知りたかったということを質問に記載するべきでした。



  • id:pochi1234
    pochi1234 2011/11/27 22:01:22
    ↑修正します。Shapeの中心位置ではなく、セル範囲の中心位置です。

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ