外出自粛中でも楽しく過ごす!QAまとめ>>

お世話になります。

エクセルのVBAでクリップボードにコピーした画像をpng(or jpg or bmp)ファイル保存したいのですが、プログラム方法がわかりません。

勝手で申し訳ございませんが、以下の条件で実現する方法をご存知の方
教えて頂ければと思います。
・VBAだけで実現したい(VBAから別ソフトを起動するなどはNG)
・クリップボードに画像コピーは前工程で終わっている(画像保存だけしたい)


何卒よろしくお願いいたします。

このQ&Aに関連する最新のQ&A

A 回答 (1件)

jpg で保存する方法です。


空のシートを作る部分だけ、若干手間を取ります。
ファイル名は面倒なので、日付時間値にしてしまいました。

'//
Sub PictureSave()
 Dim arBuf As Variant
 Dim cb As Variant
 Dim sh As Worksheet
 Dim pic As Object
 Dim objCht As Object
 Dim Fname As String
 Dim formatDate As String
 
 Set sh = ThisWorkbook.Worksheets.Add '空のシート
 arBuf = Application.ClipboardFormats
 If Not IsArray(arBuf) Then MsgBox "クリップボードに何もありません。": Exit Sub
 For Each cb In arBuf
  If cb = xlClipboardFormatBitmap Then
   sh.Paste
   Exit For
  End If
 Next
 Set pic = sh.Pictures(1)
 If pic Is Nothing Then Exit Sub
 With pic
  Set objCht = ActiveSheet.ChartObjects.Add(.Left, .Top, .Width, .Height).Chart
 End With
 formatDate = Format$(Now(), "yymmddhhmms")
 Fname = Application.GetSaveAsFilename(formatDate, "画像ファイル(*.jpg), *.jpg", , "画像の保存")
 If VarType(Fname) = vbBoolean Then Exit Sub
 pic.Copy
 objCht.Paste
 objCht.Export Fname, "jpg"
 pic.Delete
 sh.ChartObjects(1).Delete
 Application.DisplayAlerts = False
 sh.Delete 'シート削除
 Application.DisplayAlerts = True
End Sub
    • good
    • 8

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qオートシェイプを画像ファイルで保存

※Excel2003VBAです
オートシェイプを画像ファイル(BMP,PNG,jpgなど)のファイルに保存するVBAを探しています。
そもそもExcelの通常作業でも出来ないのでマクロの記録も出来ません。
サイトでもよいので教えていただけますか。

Aベストアンサー

こんにちは。

オートシェイプを画像ファイルとして保存するのは通常操作で可能です。
ファイル→Webページとして保存 を使います。
Webページとして保存を行うとファイル名.filesという名前のフォルダが作成され、その中に画像ファイルが出来ます。
ただし、この操作を「マクロの記録」で記録しても直接画像ファイルにする記述が記録されるわけではありません。
結果として出来上がると言うことなので、マクロで使うとすれば出来上がった画像ファイルをコピーしてどこかに取り出してからファイルを削除する、という方法になるかと思います。

どうでしょうか。

QエクセルVBAでクリップボード内容をクリア

こんにちは。
エクセルのVBAの処理の中で、ある部分をコピーしてそれを、
貼り付けする処理をしています。
処理終了後、ファイルを閉じるときに、クリップボードに
コピーの内容が残っている旨のメッセージがでてきます。
このメッセージを出さない様に、クリップボードの内容を
クリアするにはどのようにすればよろしいでしょうか?
申し訳ありませんが、お教え頂きますようお願いいたします。

Aベストアンサー

Excel.Application.CutCopyMode = False
Workbooks(fName).Close savechanges:=False

かな。1行目だけでいいかも。

QExcel2007のVBAで、セル範囲を指定し

Excel2007のVBAで、セル範囲を指定して画像として保存したいです。

たとえば、
Worksheets("Sheet1").Range("A1:B10").CopyPicture xlScreen, xlBitmap
Worksheets("Sheet2").Paste

とすれば、別のシートに指定した範囲を画像にすることはでき、

さらにこれを、
With ActiveWorkbook.PublishObjects.Add(xlSourceSheet, "C:\test.html", _
"Sheet2", "", xlHtmlStatic, "image", "")
.Publish (True)
.AutoRepublish = False
End With

とすれば、画像を指定した場所に保存することはできると思います。

ただ、これだと無駄な処理をしているような気がしますし、実際時間も数秒必要です。

これが、グラフだと
Worksheets("Sheet1").ChartObjects("グラフ1").Chart.Export Filename:="C:\graph.gif", FilterName:="gif"

のように簡単に、しかも短時間で出来ます。

できれば、上記グラフのように、指定したSheetの指定したセル範囲を画像として指定した場所にPNGにて保存したいです。

どなたかご教授いただければ幸いです。

Excel2007のVBAで、セル範囲を指定して画像として保存したいです。

たとえば、
Worksheets("Sheet1").Range("A1:B10").CopyPicture xlScreen, xlBitmap
Worksheets("Sheet2").Paste

とすれば、別のシートに指定した範囲を画像にすることはでき、

さらにこれを、
With ActiveWorkbook.PublishObjects.Add(xlSourceSheet, "C:\test.html", _
"Sheet2", "", xlHtmlStatic, "image", "")
.Publish (True)
.AutoRepublish = False
End With

とすれば、画像を指定した場所に保存す...続きを読む

Aベストアンサー

苦肉の策の中抜き版です。ConvCLSIDに言及してありませんでしたが、コピーされましたでしょうか。
当方では、下記により、Sub testを実行して、選択セルをpngで保存できました。

Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
Private Declare Function OpenClipboard Lib "user32.dll" ( _
Private Declare Function GetClipboardData Lib "user32.dll" ( _
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
Private Declare Function GdiplusStartup Lib "gdiplus.dll" _
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" _
Private Declare Function GdipDisposeImage Lib "gdiplus.dll" _
Private Declare Function GdipSaveImageToFile Lib "gdiplus.dll" _
Private Declare Function CLSIDFromString Lib "ole32" _

' // Types ----------------------------------------------------------
Private Type PictDesc
'略
End Type
Private Type Guid
'略
End Type

Public Enum GDIPlusStatusConstants
'略
End Enum

Private Type UUID
'略
End Type

Private Type GdiplusStartupInput
'略
End Type

Private Type EncoderParameter
'略
End Type

Private Type EncoderParameters
'略
End Type

' // Constants ------------------------------------------------------
Private Const CF_BITMAP As Long = 2
Private Const CF_PALETTE As Long = 9

Const CLSID_PNG = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"

Sub test()
Dim myPicture As StdPicture
Selection.Copy
Set myPicture = CreatePictureFromClipboard
Call SavePicturePng(myPicture, "c:\cells.png")
End Sub

' // クリップボードのビットマップデータから Picture オブジェクトを作成
Public Function CreatePictureFromClipboard() As StdPicture
'略
End Function

Public Function SavePicturePng(ByVal PicObj As IPictureDisp, ByVal FName As String) As GDIPlusStatusConstants
'略
End Function

Private Function ConvCLSID(ByVal sGuid As String) As UUID
'略
End Function

苦肉の策の中抜き版です。ConvCLSIDに言及してありませんでしたが、コピーされましたでしょうか。
当方では、下記により、Sub testを実行して、選択セルをpngで保存できました。

Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
Private Declare Function OpenClipboard Lib "user32.dll" ( _
Private Declare Function GetClipboardData Lib "user32.dll" ( _
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function OleCreatePictureIndir...続きを読む

QSavePictureで保存できない

VB6での開発で
ピクチャボックス(大)の中にピクチャボックス(小)を何個か入れ
全てのピクチャイメージを保存したいのですが「SavePicture ピクチャボックス(大), ファイル名」
を実行してもピクチャボックス(大)のみしか保存できません。
すべてのピクチャにAutoRedraw=Trueを設定しています。

どなたか分かる方がいらっしゃいましたら教えてください。
宜しくお願いします。

Aベストアンサー

ループの中の
.Picture3.Picture = LoadPicture(wkAry(i))
に続いて
.Picture3.Line (50, 50)-(2400, 150), , BF
ですよね?

問題ないままに動いております。
こちらではエラーが出ておりません。

Command1_Clickイベントを張っておきます。
-----------------------------------------------------
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
の宣言をした上で
-----------------------------------------------------
Private Sub Command1_Click()
  Dim wkAry  As Variant
  Dim i    As Long
  Dim lngCntPic  As Long
 
  '絵の情報
  wkAry = Array( _
        "C:\windows\しゃくなげ.bmp" _
       , "C:\windows\グリーン ストーン.bmp" _
       , "C:\windows\サポテック織り.bmp" _
       , "C:\windows\サンタフェ.bmp" _
       , "C:\windows\シャボン.bmp" _
       )
 
  'ピクチャの数
  lngCntPic = UBound(wkAry) + 1
 
  'スクロールピクチャの高さ取得
  lngScrollPicH = (lngCntPic + 1) * lngPicH

  With Me
    .Command1.Enabled = False
    .Command2.Enabled = True
 
    With .Picture1
      .Visible = True
    End With
  
    With .Picture2
      .Visible = True
   
      .Width = lngPicW
      .Height = lngScrollPicH
      .Left = 0
      .Top = lngPicH - lngScrollPicH
    End With
  
    For i = 0 To lngCntPic - 1
      .Picture3.Picture = LoadPicture(wkAry(i))
      .Picture3.Line (50, 50)-(2400, 150), , BF
      'イメージを取得したいので、ペイントピクチャは使用しない
      'Call .Picture2.PaintPicture(.Picture3.Picture, 0, (lngCntPic - i) * lngPicH, lngPicW, lngPicH, 0, 0, .Picture3.ScaleWidth, .Picture3.ScaleHeight, vbSrcCopy)
      'イメージを取得したいので、ストレッチぶりっとを使用する
      Call StretchBlt(.Picture2.hdc, 0, (lngCntPic - i) * lngPicH, lngPicW, lngPicH, Picture3.hdc, 0, 0, .Picture3.ScaleWidth, .Picture3.ScaleHeight, vbSrcCopy)
      If i = 0 Then
        'Call .Picture2.PaintPicture(.Picture3.Picture, 0, 0, lngPicW, lngPicH, 0, 0, .Picture3.ScaleWidth, .Picture3.ScaleHeight, vbSrcCopy)
        Call StretchBlt(.Picture2.hdc, 0, 0, lngPicW, lngPicH, Picture3.hdc, 0, 0, .Picture3.ScaleWidth, .Picture3.ScaleHeight, vbSrcCopy)
      End If
    Next i
  
  End With
 
End Sub

ループの中の
.Picture3.Picture = LoadPicture(wkAry(i))
に続いて
.Picture3.Line (50, 50)-(2400, 150), , BF
ですよね?

問題ないままに動いております。
こちらではエラーが出ておりません。

Command1_Clickイベントを張っておきます。
-----------------------------------------------------
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Lon...続きを読む

QVBAマクロで、図形等のオブジェクトを選択(特定)する方法ってありますか

こんにちは。VBAマクロを少しかじっています。
顔写真付きの従業員の検索システムを作りました。名前を入力(選択)したら、データシートから職員コード、住所、電話番号などの情報を検索し検索画面に表示します。この際、別のシートに顔写真を貼り付けたもの(1セルに1枚。セルに従業員名を入力してある。)から、VLOOKUP関数を使ってセル照会することで、画像も同時に表示することができます。
別の職員に切り換えたり、クリアする場合の画像の処理は、削除用のシートを用意し、そこにセルごと移動し、終了時にシートごと削除する方法をとりました。(当然、確認用のダイアログボックスが表示されます。)
前置きが長くなりましたが、問題は、用済みの画像を選択するプロシージャがあれば、あえて削除用のシートを用意する必要はありません。セルの場合は、Rangeプロパティやcellsプロパティで特定できますが、画像などのオブジェクトをセル番地などを使って特定する方法ってあるのでしょうか。
因みに、画像の選択処理を、マクロ記録でプロシージャを作成したら、
ActiveSheet.Shapes("Picture 1").Select などとなります。
よろしくお願いします。

こんにちは。VBAマクロを少しかじっています。
顔写真付きの従業員の検索システムを作りました。名前を入力(選択)したら、データシートから職員コード、住所、電話番号などの情報を検索し検索画面に表示します。この際、別のシートに顔写真を貼り付けたもの(1セルに1枚。セルに従業員名を入力してある。)から、VLOOKUP関数を使ってセル照会することで、画像も同時に表示することができます。
別の職員に切り換えたり、クリアする場合の画像の処理は、削除用のシートを用意し、そこにセルごと移動し、終了時...続きを読む

Aベストアンサー

検索シートにシェイプが1つしかなければ
ActiveSheet.Shapes(1).Select
で選択
ActiveSheet.Shapes(1).Delete
で削除できます。

Qエクセル VBAで画像の保存方法を教えてください。

お疲れさまです。
質問ばかりですみません。

エクセルで以下URLの画像を保存したいのですが、拡張子が取得できずうまく保存できません。
どなたか詳しい方がいらっしゃいましたら、教えて頂きたくお願いいたします。

<取得したいURL>
http://www.asos.com/asos/asos-kimono-sleeve-mini-skater-dress-in-red-lace/prod/pgeproduct.aspx?iid=6965375&clr=Red&cid=19680&pgesize=36&pge=0&totalstyles=2601&gridsize=3&gridrow=1&gridcolumn=1

<マクロで取得した画像のリンク>
ここにjpg等がつけば保存できるとおもうのですが・・・・

http://images.asos-media.com/products/asos-kimono-sleeve-mini-skater-dress-in-red-lace/6965375-4?$XXL$&wid=513&fit=constrain

http://images.asos-media.com/products/asos-kimono-sleeve-mini-skater-dress-in-red-lace/6965375-1-red?$XXL$&wid=513&fit=constrain

http://images.asos-media.com/products/asos-kimono-sleeve-mini-skater-dress-in-red-lace/6965375-2?$XXL$&wid=513&fit=constrain

http://images.asos-media.com/products/asos-kimono-sleeve-mini-skater-dress-in-red-lace/6965375-3?$XXL$&wid=513&fit=constrain

お疲れさまです。
質問ばかりですみません。

エクセルで以下URLの画像を保存したいのですが、拡張子が取得できずうまく保存できません。
どなたか詳しい方がいらっしゃいましたら、教えて頂きたくお願いいたします。

<取得したいURL>
http://www.asos.com/asos/asos-kimono-sleeve-mini-skater-dress-in-red-lace/prod/pgeproduct.aspx?iid=6965375&clr=Red&cid=19680&pgesize=36&pge=0&totalstyles=2601&gridsize=3&gridrow=1&gridcolumn=1

<マクロで取得した画像のリンク>
ここにjpg等がつ...続きを読む

Aベストアンサー

こちらでも聞いておられたようですね。
もう別の質問で回答をしていましたが、その一片を残しておきます。
それにしても、きれいな人たちが着るから、きれいにみえるのでしょうね。全体的に落ち着いた色合いですね。

コードが自動で変換されるので、[&quot:; ->"] このような文字列は注意して、

'//
  With objIE
   Dim RetVal As Long
   Dim strFname As String
   Dim arFnames() As Variant
   Dim galImgs As Object
   Dim i As Long, j As Long
   Dim ea As Variant, src
   '後につけたものは、宣言が抜けています。
   i = 1
   Set galImgs = .Document.getElementsByClassName("gallery-image")
   
   If galImgs.Length > 0 Then
    ReDim arFnames(galImgs.Length - 1)
     'ダウンロード名の決定
    strFname = Replace(galImgs(0).href, "http://images.asos-media.com/products/", "")
    strFname = Mid(strFname, 1, InStr(strFname, "/") - 1)
    For Each ea In galImgs
     If ea.Nodename = "IMG" Then
       Fname2 = Left$(ea.nameProp, InStr(ea.nameProp, "?") - 1)
       ext = Left$(ea.mimeType, InStr(ea.mimeType, " ")) '*←ここで取ります。(欲を言うと、小文字にしたい)
       Fname2 = Fname2 & "." & ext
      End If
     src = ea.href
     If src Like "http://*" Then
      'RetVal = URLDownloadToFile(0&, src, strFname & "_" & i & ".jpg", 0&, 0&)
      'arFnames(i - 1) = strFname & "_" & i & ".jpg"
      RetVal = URLDownloadToFile(0&, src, Fname2, 0&, 0&)
      arFnames(i - 1) = Fname2
      i = i + 1
      If i > 4 Then Exit For '5枚以上は離脱
     End If
    Next
   End If

こちらでも聞いておられたようですね。
もう別の質問で回答をしていましたが、その一片を残しておきます。
それにしても、きれいな人たちが着るから、きれいにみえるのでしょうね。全体的に落ち着いた色合いですね。

コードが自動で変換されるので、[&quot:; ->"] このような文字列は注意して、

'//
  With objIE
   Dim RetVal As Long
   Dim strFname As String
   Dim arFnames() As Variant
   Dim galImgs As Object
   Dim i As Long, j As Long
   Dim ea As Variant, src
   '...続きを読む

QエクセルVBAで画像を貼り付ける座標設定方法は?

Sheets("Sheet1")に貼り付けたJ-pegの画像(=シンボルマーク)を別なシートに貼り付けるのは下記のVBAで出来ました。ただ、これでは貼り付け先のシートのセルK12が、貼り付け元のK12と同じ位置でないと思った場所に張り付きません。
そこでセルで場所を指定するのではなく、座標のようなもので指定する方法はないものかと考えた次第です。
オートシェイプなどは座標指定で作成できるのですが、J-pegのような画像はどうすればいいのでしょうか?

Sub TEST()
Sheets("FACE").Shapes("シンボルマーク").Copy
ActiveSheet.Range("K12").Select
ActiveSheet.Paste
End Sub

Aベストアンサー

#1です。
>この場合、ファイルをエクセルにくっつけて渡すなんてこと
>はできないものでしょうか?(別々にではなくあくまでエク
>セルのブックに付属した形で)
Excelのブックに付属した形にするなら、コピーペーストする方がいいと思います。一旦挿入した画像を別途保存するのは、簡単には出来ないと思います。

複数のシートで同じような作業をするなら、次のような方法も考えられます。
Function CpyMrk(MrkNM As String, myTop As Single, myLeft As Single)
Sheets("FACE").Shapes(MrkNM).Copy
ActiveSheet.Paste
ActiveSheet.Shapes(MrkNM).Top = myTop
ActiveSheet.Shapes(MrkNM).Left = myLeft
End Function

Sub test()
CpyMrk "シンボルマーク", 10, 10
End Sub

QEXCEL VBA で現在開いているブックのファイル名を取得する方法

EXCEL2003 VBAで業務を簡素化するために、現在開いているブックのファイル名を取得する方法が分かりません。
作業手順をマクロを使って処理していますが、オリジナルのワークブックをファイル名を変えて保存し、以後、このワークブックを読み込んで使用しています。
このときのVBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり、以後の業務に使用できません。
常にファイル名を取得出来るVBAをどなたか、教えて下さい。

Aベストアンサー

>現在開いているブックのファイル名
 ちょっと曖昧な表現かなぁという気もいたしますが、VBAが書いてあるブックのブック名は
ThisWorkbook.Name
で、現在 "アクティブにして" 操作対象になっているブックの名前は
ActiveWorkbook.Name
ですね。

 しかし、
>VBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり
というような文脈からすると、
ThisWorkbook.Name
の方ですかね。

Qエクセルで貼り付けたオブジェクトの画像をユーザーフォームのイメージコントロールで表示する方法

エクセルで画像をオブジェクトで作り、ユーザーフォームに作ったイメージコントロールに表示する方法はないでしょうか?
条件によってイメージの画像が切り替わるようにしたいのですが。
別の画像ファイルから読み出すことはあまりしたくありません。あくまでエクセルの中にある画像からフォームのイメージに表示したいのですが。何かいい方法があれば教えてください。

回答よろしくお願いします。

Aベストアンサー

(#2コメントへのレスです)
とりあえず
http://www.google.co.jp/search?q=win32api%E3%81%A8%E3%81%AF%3F&lr=lang_ja
http://wisdom.sakura.ne.jp/system/winapi/win32/win1.html
VB系から扱うなら
http://www.winapi-database.com/Beginner/page1.html
ですが、中途半端に手を出すと少々やっかいかも。当り前の事ですが、自己責任でお願いします。

それより
>本当はワークシート上で画像を表計算のデータと同じようにデータとして扱って作りたかったのです
なら
http://www.officetanaka.net/excel/function/tips/tips14.htm
http://www.geocities.jp/chiquilin_site/data/050530_search.html
...のあたりが参考になるかもしれませんね。

QVBAでwebの画像を名前を付けて保存する方法

下記でエクセルのシートには保存はできましたが直接画像をjpegでファイルとして保存するにはどうすれば良いでしょうか?
マクロの記録では無理でした・・・
どなたかご存知の方よろしくお願いいたします。
Sub test()
Dim IMG As Variant
Dim wbooks As Workbook
Dim Filename As String
Set wbooks = Workbooks.Add
Filename = "C:\テスト\" & Format(Date - 1, "yyyymmdd") & ".xlsx"
wbooks.SaveAs (Filename)
IMG = "http://t-success.co.jp/image.jpg"
With ActiveSheet.Pictures.Insert(IMG)
.Top = Range("A1").Top
.Left = Range("A1").Left
End With
wbooks.Save
End Sub

Aベストアンサー

知恵袋に回答がありました。ご参考まで。
下記では画像ファイルがpngとなっていますのでjpgに変更する事と、JRLアドレスの変更で可能だと思います。

http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1449318889


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング