質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.32%

VBA を使用してWeb上の画像を貼り付ける方法(40321の追加質問です)

解決済

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 1,745

bll_luxlife

score 5

実現したいこと

下記の質問への回答に対する追加質問で、
画像を取り込んだ後のペースト方法についてです:
https://teratail.com/questions/40321

URLから画像は取り込めましたが、
左上を起点としてペーストされます。

以下のようなペースト方法についてアドバイスをいただければ助かります:

1.セルのセンター(上下左右)への配置
2.縦横比を保持したたまま、セルサイズに合わせてリサイズ

調べてみたのですが、的確な回答をまだ見つけられていないので、ここで質問させていただく次第です。

下記、使用したコードです:
後半"Set objShape"以降の部分になると思いますが、詳しい方のアドバイスをいただければと思います。

該当のソースコード

Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub GetPicture()

Dim strFname As String, strURL As String
Dim retValue As Long, i As Long
Dim endRow As Long
Dim objShape As Object

endRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To endRow
strURL = Cells(i, 1).Text

If strURL <> "" Then
strFname = "C:DownloadPic\" & Mid(strURL, InStrRev(strURL, "/") + 1)
retValue = URLDownloadToFile(0, strURL, strFname, 0, 0)

If retValue = 0 Then

With Cells(i, 2)

Set objShape = ActiveSheet.Shapes.AddPicture( _
Filename:=strFname, LinkToFile:=False, _
SaveWithDocument:=True, Left:=.Left, _
Top:=.Top, Width:=0, Height:=0)

With objShape
.ScaleHeight 1!, msoTrue
.ScaleWidth 1!, msoTrue
.ScaleHeight 30! / .Width, msoTrue
.ScaleWidth 30! / .Width, msoTrue
End With
Set objShape = Nothing

End With
Else
MsgBox "Complete"
End If
End If
Next i
End Sub

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

checkベストアンサー

+1

.Shapes.AddPicture ではなく .Pictures.Insert を使ってならこんな感じです

Dim objPic As Object

・・・

With Cells(i, 2) 

Set objPic = ActiveSheet.Pictures.Insert(strFname)

'縦横の縮尺を保持しながらセルサイズに合わせる
myH = .Height / objPic.Height
myW = .Width / objPic.Width
If myH > myW Then
  objPic.Height = objPic.Height * myW
  objPic.Width = .Width
Else
  objPic.Height = .Height
  objPic.Width = objPic.Width * myH
End If

'セルの中央へ配置
objPic.Top = .Top + ((.Height - objPic.Height) / 2)
objPic.Left = .Left + ((.Width - objPic.Width) / 2)

Set objPic = Nothing

End With

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2016/07/15 00:04

    ご回答ありがとうございます。
    ひとまず目標としていたことはできましたが、画像サイズがセルに対して小さすぎるものが一部ありました。オリジナルの画像はそこまで小さいものでないのですが、教えていただいたコードの特性をもう少し勉強してみます。
    ありがとうございました。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 90.32%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

同じタグがついた質問を見る