エクセル図のJPEG出力

Question

現在、エクセル内で作った図をカメラで撮って、これをコピーして、JTrimというソフトに張付け→JPEGを選択→名前を付けて→デスクトップに出力し　していますが、この操作をエクセル内でスクリプトを組んで、一発（スタートボタン）で出力できないでしょうか？あるいは、他の方法でも良いのですが、エクセル内の図を簡単にデスクトップにJPEG形式で出力する方法を教えて頂けませんか？目的はブログに乗せる図を作ることですが、何時ながらもっと簡単にできないかと思っています。宜しくお願いいたします。

tsubuyuki · Accepted Answer

> エクセル内でスクリプトを組んで、一発（スタートボタン）で出力
出来ないことは無いですよ。
エクセルでは主にＶＢＡと呼ばれる言語を使うのですが、
要するに外部アプリケーションを起動して、貼り付けてやればＯＫってことです。

以下は、ＪＴＲＩＭを起動して、貼り付けて、Ａｌｔ＋Ｆ４を押して
保存するかどうか聞く、までのサンプルです。

Sub Sample()
Dim APPID As Double
Dim APPWait As Long

Selection.Copy

APPID = Shell("フルパス\JTrim.exe", vbNormalFocus)
　　　　APPWait = Timer

Do While Timer < APPWait + 1
　　　　　　　　DoEvents
　　　　Loop
　　　　AppActivate APPID

Application.SendKeys "^V", True
　　　　Application.SendKeys "%{F4}", True
End Sub

出力したい図を選択した状態で上記を走らせると、
ＪＴＲＩＭを起動して、貼り付けてくれます。

あとはこれをボタンなりリボンなりスマートアイコンに登録してやれば
お望みの「一発（スタートボタン）」に出来ると思いますよ。

mitarashi · Answer

#4～です。しつこくて済みません。
レジストリが「思います」では無責任かと思って試してみました。
#4のコードには、#6のQuality設定が有効でした。添付の画像（元サイズは1331×855ピクセル)でファイルサイズが、Quality90の時71KB、75の時47KB、15の時24KBでした。この手の画像では90と75は画質の顕著な差は認められませんでした。
また、#5のコードについては、#6のQuality設定は無効でした。

なお、GDI+を用いて、Quality設定も任意に行える方法（APIが少々高レベルになってきますが）を下記#5で、KenKenSPさんが回答されています。
http://oshiete.goo.ne.jp/qa/5124395.html

mitarashi · Answer

#4,5です。たびたびすみません。
グラフィックフィルターの圧縮率設定は、Windows7Home(64bit）の場合下記だと思います。
圧縮率のデフォルトは、間違えて覚えていましたが、75でした。画質が眠い訳ですね。
書き換える場合は、自己責任でお願いします。
\HKEY_CURRENT_USER\Software\Microsoft\Shared Tools\Graphics Filters\Export\JPEG\Options\Quality

古い記事には下記だとありましたが、そちらには該当項目がありませんでした。
\HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Shared Tools\Graphics Filters\Export\JPEG\Options\Quality

mitarashi · Answer

#4です。すごく簡単なコードがあったのを思い出しました。
ワークシート上で空のセル一個だけを選択して、挿入・グラフで白紙のグラフを作成します。
（他にはグラフが存在しないことを前提にしています）
この白紙グラフ上に図形を描画します。
下記コードでJPEGで保存できます。

'Activateしないとエラーになる様です。
Sub test()
  ActiveSheet.ChartObjects(1).Activate
  ActiveChart.Export GetDesktopPath & "\graph.jpg"
End Sub

Private Function GetDesktopPath() As String
  Dim wScriptHost As Object, strInitDir As String
  Set wScriptHost = CreateObject("Wscript.Shell")
  GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
  Set wScriptHost = Nothing
End Function

mitarashi · Answer

VBAで行う例です。目的の図を選択してから、Sub 動作テスト()を実行します。
昔のコレクションを引っ張り出してみると、動作しない！Officeのグラフィックフィルターの在処がWindows7(64bit)では変わっていたのが原因でした。環境に合わせて修正する必要があります。Windows7Home(64bit), XL2010(32bit)で試しています。

Private Type FLTIMAGE
    StructSize As Integer
    Type As Byte
    Reserved1(0 To 8) As Byte
    hImage As Long
    Reserved3(0 To 19) As Byte
End Type
Private Type FLTFILE
    Reserved1 As Integer
    Ext As String * 4
    Reserved2 As Integer
    Path As String * 260
    Reserved3 As Currency
End Type

'Office(32bit)のグラフィックフィルターAPI
'XP(32bit)の時はここにありました
'C:\Program Files\Common Files\Microsoft Shared\Grphflt\JPEGIM32.FLT"

'Windows7Home(64bit)では下記にあります。
Private Declare Function GetFilterInfo Lib _
  "C:\Program Files (x86)\Common Files\microsoft shared\GRPHFLT\JPEGIM32.FLT" _
   (ByVal Ver As Integer, ByVal Reserved As Long, _
    phMem As Long, ByVal flags As Long) As Long
'jpegの圧縮率は85%固定で変更するにはレジストリをいじる必要があったと思います。
'Web検索してみましたが発見できていません。

Private Declare Function ExportGr Lib "JPEGIM32.FLT" _
   (ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
Private Const SaveExt As String = "Jpeg保存,*.Jpg"

Private Declare Function OpenClipboard Lib "user32" _
        (ByVal hWndNewOwner As Long) As Long
Private Declare Function GetClipboardData Lib "user32" _
        (ByVal uFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Const CF_ENHMETAFILE = 14
Private Declare Function CopyEnhMetaFile Lib "gdi32" _
       Alias "CopyEnhMetaFileA" _
        (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" _
       (ByVal hemf As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" _
       (ByVal hMem As Long) As Long

Sub 動作テスト()
    Dim myPath
    
    myPath = GetDesktopPath & "\fltTest.jpg"
    Call Selection.CopyPicture(xlPrinter, xlPicture)
    If SaveCBPictureAs(myPath) Then
        MsgBox "保存しました", vbInformation, Dir(myPath)
    Else
        MsgBox "失敗しました"
    End If
End Sub

Function SaveCBPictureAs(ByVal SavePath As String) As Boolean
  Dim fi   As FLTIMAGE
  Dim ff   As FLTFILE
  Dim hemf As Long
  Dim hMem As Long

If OpenClipboard(0) Then
      hemf = CopyEnhMetaFile( _
              GetClipboardData(CF_ENHMETAFILE), vbNullString)
      CloseClipboard
  End If
  If hemf = 0 Then
    Exit Function
  End If
  ff.Path = SavePath & vbNullChar
  With fi
      .StructSize = LenB(fi)
      .Type = 1
      .hImage = hemf
  End With
  ' フィルタ呼び出し
  If GetFilterInfo(3, 0, hMem, &H10000) And &H10 Then
      If ExportGr(ff, fi, hMem) = 0 Then
          SaveCBPictureAs = True
      End If
  End If
  If hMem Then GlobalFree hMem
  DeleteEnhMetaFile hemf
End Function

'最近のWindowsではフォルダーへのアクセス権の問題があるので、便宜上Desktopを対象にしています。
Private Function GetDesktopPath() As String
  Dim wScriptHost As Object, strInitDir As String
  Set wScriptHost = CreateObject("Wscript.Shell")
  GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
  Set wScriptHost = Nothing
End Function

Safe_Mode · Answer

ANo.1です。
画像ファイルフォルダーにはpng形式で保存されるようですね。（Excel2010で確認）
ブログ側でpng形式でも対応可能ならそのまま使ってもいいですし、jpegでなければ・・・ということならJTrimに取り込んでjpeg形式で保存し直してもいいでしょう。

この他にも、当該ExcelファイルをPDF形式のファイルで保存してPDFファイルの中から画像選択ツールで図を選択することで図だけ取り出すことも可能ですし、Windows7やWindows8ならExcelファイルを表示させておいてSnipping Toolで図だけキャプチャして取り出すことも可能です。

Safe_Mode · Answer

このような質問をされるなら、使っているExcelのバージョンも明記してください。
Excelファイルを開き「名前を付けて保存」します。この時ファイルの種類を「Webページ（*.htm;*.html）」とします。
これで保存すると、ファイル名と同名の画像フォルダが自動的に作成され、その中に当該Excelのシート中の図形がgif形式で保存されているはずです。
jpeg形式でなくてもブログにアップする目的ならgif形式でも充分でしょう。

エクセル図のJPEG出力

> エクセル内でスクリプトを組んで、一発（スタートボタン）で出力

この回答への補足

#4～です。

この回答への補足

#4,5です。

#4です。

VBAで行う例です。

ANo.1です。

このような質問をされるなら、使っているExcelのバージョンも明記してください。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング