ここから本文です

マクロ初心者です。 エクセル2010使用しています。 馬鹿が何か変なことやってる...

アバター

ID非公開さん

2018/3/3011:24:24

マクロ初心者です。
エクセル2010使用しています。
馬鹿が何か変なことやってると思ってください。

png形式の画像は LoadPictureに未対応なので、bmpに変換して別シートの特定の結合したセルにサイズを合わせるマクロを作りたいのです。他の方の質問に似たようなマクロがありましたのでそれをコピーして少し書き換えてみましたがピクチャが不正ですと出ます。
どこをどう直したら良いのかわからず2日無駄にしています。
どなたかご教授お願い致します。

Sub sample()
Dim fname As Variant
Dim tmp1 As String, tmp2 As String
Dim shp As Object
Dim cellw As Double, cellh As Double
Dim ww As Double, hh As Double
Application.DisplayAlerts = False
'pngファイル選択
fname = Application.GetOpenFilename("PNGファイル(*.png),*.png", MultiSelect:=False)
If VarType(fname) = vbBoolean Then Exit Sub
'bmpで保存
tmp1 = Left(fname, Right(InStrRev(fname, "\"), Len(fname) - InStrRev(fname, "\")))
tmp2 = Mid(fname, Len(tmp1) + 1, Len(fname) - Len(tmp1) - 3)
FileCopy fname, tmp1 & tmp2 & "bmp"
'アクティブセルの大きさ
With Worksheets("sheet2").Range("A108")
cellw = .MergeArea.Width
cellh = .MergeArea.Height
'画像の比率
Set shp = LoadPicture(tmp1 & tmp2 & "bmp")
If (shp.Width / cellw) > (shp.Height / cellh) Then
ww = cellw
hh = shp.Height / (shp.Width / cellw)
Else
ww = shp.Width / (shp.Height / cellh)
hh = cellh
End If
'添付
Set shp = Worksheets("sheet2").Shapes.AddPicture(Filename:=tmp1 & tmp2 & "bmp", _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=.Left + (cellw - ww) / 2, Top:=.Top + (cellh - hh) / 2, Width:=ww, Height:=hh)
End With

End Sub




Set shp = LoadPicture(tmp1 & tmp2 & "bmp")←この部分でエラーが出ます。

閲覧数:
94
回答数:
2

違反報告

ベストアンサーに選ばれた回答

db1********さん

2018/3/3011:54:51

addpictureを使うと、pngをセルに貼り付けできます。

参考
Sub 画像貼付_セルのサイズ()
' Excel 2007
Dim StrFilter As String
Dim 画像ファイル As Variant
Dim Tate As Single
Dim Yoko As Single
Dim Top As Single
Dim Left As Single
Dim PicData As Object

' Tate = ActiveCell.Height
Tate = ActiveCell.MergeArea.Height
' Yoko = ActiveCell.Width
Yoko = ActiveCell.MergeArea.Width

画像ファイル = ""
StrFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"


画像ファイル = Application.GetOpenFilename(FileFilter:=StrFilter, _
FilterIndex:=1, _
Title:="画像ファイルを選択してください。", _
MultiSelect:=False)

If 画像ファイル = "False" Then Exit Sub

Top = ActiveCell.Top
Left = ActiveCell.Left

' ActiveSheet.Shapes.AddPicture 画像ファイル, True, True, Left, Top, Yoko, Tate
Set PicData = ActiveSheet.Shapes.AddPicture(画像ファイル, True, True, Left, Top, Yoko, Tate)

ActiveSheet.Hyperlinks.Add Anchor:=PicData, Address:=画像ファイル

Set PicData = Nothing

Exit Sub

' 下記は必要があれば有効とするが、デフォルトでは無効。
' 画像にハイパーリンクを設定
ActiveSheet.Hyperlinks.Add Anchor:=PicData, Address:=画像ファイル
' リンク先をセルに代入しハイパーリンクを設定する
ActiveCell.Offset(1).Value = 画像ファイル
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell.Offset(1), Address:=画像ファイル
ActiveCell.Offset(1).ShrinkToFit = True

ActiveCell.Offset(, 1).Select

End Sub

  • アバター

    質問者

    ID非公開さん

    2018/3/3014:51:56

    早速の回答ありがとうございます。

    教えて頂いたマクロすごいですね!

    選択したセルに合わせて画像のサイズが調整されていますが、これをコピー先「sheet2」のA108からE119の結合されたセルにサイズを調整し、貼り付けるためにはどうしたらよいでしょうか?

  • その他の返信(3件)を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

アバター

質問した人からのコメント

2018/4/2 09:40:05

親切で的確な回答で大変勉強になりました。

本当に助かりました。
有難うございました。

ベストアンサー以外の回答

1〜1件/1件中

nor********さん

2018/3/3012:11:27

tmp1 = Left(fname, Right(InStrRev(fname, "\"), Len(fname) - InStrRev(fname, "\")))

は下の間違えじゃないでしょうか?

tmp1 = Left(fname, Right(fname, Len(fname) - InStrRev(fname, "\")))

上記の場合、png→bmpへのフォーマットの変換は行われていないと思います。
単純にファイルの拡張子を変更しているだけです。

LoadPictureで実際よみこまれているのは、bitmapです。
だから失敗しているのではないかと思います。

AddPictureはPNGも読めこめそうなので、一旦Shapeオブジェクトを作成
したあと、Shapeオブジェクトの幅、高さを変更すれば行けると思います。

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

あわせて知りたい

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる