AIと戦って、あなたの人生のリスク診断 >>

VBAで
1.JPGファイルを読み込み
2.読み込んだJPGファイルの画像サイズ変更
3.再度JPG出力

の処理を行いたいのですが、どなたか分かる方がいますでしょうか?
サンプルコード、関連サイトなど教えていただけると幸いです。

お時間のある方、是非教えてください。

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

A 回答 (6件)

某掲示板でshiraさんという方から教わったコードをアレンジさせていただきました。

宣言部は別途投稿します。
Sub test()
Dim src As String,dst As String

src="c:\s.jpg"
dst="c:\d.jpg"
If Dir(dst) <> "" Then Kill (dst)
Call resizePicture(src,dst,20,7,70)
End Sub

Function resizePicture(ByVal srcPath As String,_
ByVal dstPath As String,_
Optional ByVal scalerate As Long=100,_
Optional ByVal InterpolationMode As InterpolationMode=InterpolationModeHighQualityBicubic,_
Optional ByVal jpegQuality As Long=85)
Dim IID_IDispatch As GUID
Dim pd As PICTDESC
Dim udtInputAs GdiplusStartupInput
Dim lngTokenAs Long,lngStatus As Long
Dim pGraphics As Long
Dim pSrcBmp As Long,pDstBmp As Long
Dim lngWidthAs Long,lngHeight As Long
Dim EncodParameters As EncoderParameters

udtInput.GdiplusVersion=1
If GdiplusStartup(lngToken,udtInput,ByVal 0&)<>0 Then
Exit Function
End If

If GdipCreateBitmapFromFile(ByVal StrPtr(srcPath),pSrcBmp)<>0 Then
GdiplusShutdown lngToken
Exit Function
End If

GdipGetImageWidth pSrcBmp,lngWidth
GdipGetImageHeight pSrcBmp,lngHeight
lngWidth=lngWidth * scalerate \ 100
lngHeight=lngHeight * scalerate \ 100

If GdipGetImageGraphicsContext(pSrcBmp,pGraphics)=0 Then
lngStatus=GdipCreateBitmapFromGraphics(lngWidth,lngHeight,pGraphics,pDstBmp)
GdipDeleteGraphics pGraphics
If lngStatus=0 Then
If GdipGetImageGraphicsContext(pDstBmp,pGraphics)=0 Then
GdipSetInterpolationMode pGraphics,InterpolationMode
GdipDrawImageRectI pGraphics,pSrcBmp,0,0,lngWidth,lngHeight
GdipDeleteGraphics pGraphics
EncodParameters.Count=1
With EncodParameters.Parameter(0)
.GUID=ConvCLSID(CLSID_Quality)
.NumberOfValues=1
.Type=4
.Value=VarPtr(jpegQuality)
End With
Call GdipSaveImageToFile(pDstBmp,StrPtr(dstPath),ConvCLSID(CLSID_JPEG),VarPtr(EncodParameters))
End If
GdipDisposeImage pDstBmp
End If
End If
GdipDisposeImage pSrcBmp
GdiplusShutdown lngToken
End Function

Private Function ConvCLSID(ByVal sGuid As String) As GUID
CLSIDFromString StrPtr(sGuid),ConvCLSID
End Function
    • good
    • 1

#3です。

前から気になっていたのですが、ようやく原因がわかりました。
リサイズの補間モードが、
InterpolationModeHighQualityBicubic
だと、左端と、上端に灰色の線が出来てしまいます。白基調の画像だと気になると思います。
InterpolationModeBicubic (=4)
等を選択するか、事前に白で塗りつぶしておく様にしてください。
GdipSetInterpolationMode pGraphics, InterpolationMode
'------- これを追加 dim hBrush as long を宣言要
GdipCreateSolidFill &HFFFFFFFF, hBrush
GdipFillRectangle pGraphics, hBrush, 0, 0, lngWidth, lngHeight
GdipDeleteBrush hBrush
'------- ここまで
GdipDrawImageRectI pGraphics, pImageTemp, 0, 0, lngWidthd, lngHeightd
    • good
    • 0

#2です



簡単に出来るかと思ったら、かなり、面倒でした。

VBAのオブジェクトブラウザでは、ないコマンドが
オートマクロで、達成されていたり、

vbaのヘルプを見たら、
画像フォーマットを変えられそうだったのですが。
それも出来なかったみたいでです。

でも、jpegの画像ファイルを、1/5のサイズに変換するのが
実に、単純な、コードで終わりました。
でも、保存された画像は、jpegになるかどうかは、
結果を見てみないと解らないみたいです。

Public Sub f()

ActiveSheet.Pictures.Insert("filepath.JPG").Select

Selection.ShapeRange.Width = Selection.ShapeRange.Width / 5#
Selection.ShapeRange.Height = Selection.ShapeRange.Height / 5#

ActiveWorkbook.SaveAs Filename:= "Book1.htm",FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False

End Sub

単純な、動作なので、自分でオートマクロで作ってみたら、
確実なコードが、得られると思います。
簡便方としては、良いのでは、ないですか??
    • good
    • 0

#3の続きというか、こちらの方が前なのですが。

GDI+の関数名は長いので、2K文字に納めるのに疲れました。不足する関数・定数は
http://okwave.jp/qa/q5124395.html
のKenKen_SPさんのご回答をご参照下さい。
Public Enum GDIPlusStatusConstants
Ok = 0
'(略)
End Enum
Public Enum InterpolationMode
'(略)
InterpolationModeBilinear = 3
InterpolationModeBicubic = 4
InterpolationModeNearestNeighbor = 5
InterpolationModeHighQualityBilinear = 6
InterpolationModeHighQualityBicubic = 7
End Enum
Type PICTDESC
cbSizeofstruct As Long
picType As Long
hbitmap As Long
hpal As Long
unused_wmf_yExt As Long
End Type
Declare Function GdipGetImageGraphicsContext Lib "gdiplus" _
(ByVal image As Long, graphics As Long) As Long
Declare Function GdipDeleteGraphics Lib "gdiplus" _
(ByVal graphics As Long) As Long
Declare Function GdipSetInterpolationMode Lib "gdiplus" _
(ByVal graphics As Long, _
ByVal nInterpolationMode As InterpolationMode) As Long
Declare Function GdipGetImageWidth Lib "gdiplus" _
(ByVal image As Long, Width As Long) As Long
Declare Function GdipGetImageHeight Lib "gdiplus" _
(ByVal image As Long, Height As Long) As Long
Declare Function GdipDrawImageRectI Lib "gdiplus" _
(ByVal graphics As Long, ByVal image As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal Width As Long, ByVal Height As Long) As Long
Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
(fileName As Any, bitmap As Long) As Long
Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" _
(ByVal Width As Long, ByVal Height As Long, _
ByVal target As Long, bitmap As Long) As Long

Const CLSID_JPEG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Const CLSID_Quality = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
    • good
    • 0
この回答へのお礼

mitarashiさん
ご丁寧にコードの記述ありがとうございます。

内容確認しながら試してみます。

ほんとにありがとうございます。

お礼日時:2010/02/06 01:20

検索したら、面白い方法が、



jpegの画像を、sheetに貼り付けて、
画像サイズを調整して、web保存、、、
ホームページになりますが。
画像は、イメージファイルになり、web保存時に
vbaで、容易に、jpegにできそうです。

一連の動作を、vbaにすれば、
image.jpegのファイル名で、ファイルサイズを
調整できそうです。
    • good
    • 0
この回答へのお礼

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

自分でも書けそうなレベルなので
検討してみます!!

お礼日時:2010/02/06 01:23

この回答への補足

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

明熊JPEG保存DLL

は自分もネットで見つけましたが
自分のPC以外でも作業する場合があるので
他の方法を探していました。

質問には書いておりませんでした。
ご回答くださったのにすみません。。。


ありがとうございました。

補足日時:2010/02/06 01:24
    • good
    • 0

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

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

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

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

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

Qエクセルに画像を貼付け縮小する作業をマクロにしたいのですが、

エクセルに画像を貼付け縮小する作業をマクロにしたいのですが、
分からない部分があって困ってます。

(1)挿入したいセルにカーソルを合わせる
(2)マクロ
 挿入-図-ファイル-図の挿入-図の書式設定-サイズ-30%

この作業を覚えさせると以下になりました。

Sub Macro3()
ActiveSheet.Pictures.Insert("C:\Documents and Settings\デスクトップ\1.JPG") _
.Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 360#
Selection.ShapeRange.Width = 480#
Selection.ShapeRange.Rotation = 0#
End Sub

これだと、写真が指定されてしまいます。
マクロの途中で止まって任意の写真を都度選べるようにできますか?
膨大な量の写真をセルに並べていきたいのです。

エクセルに画像を貼付け縮小する作業をマクロにしたいのですが、
分からない部分があって困ってます。

(1)挿入したいセルにカーソルを合わせる
(2)マクロ
 挿入-図-ファイル-図の挿入-図の書式設定-サイズ-30%

この作業を覚えさせると以下になりました。

Sub Macro3()
ActiveSheet.Pictures.Insert("C:\Documents and Settings\デスクトップ\1.JPG") _
.Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 360#
Selection.ShapeRange.Width =...続きを読む

Aベストアンサー

私も画像の取り込みでマクロをいじった経験があります。
こういうのはどうでしょう?(今動作確認できないのですが…)

Sub test()
ActiveSheet.Pictures.Insert(Application.GetOpenFilename).Select
Selection.Height = Selection.Height * 0.3
Selection.Width = Selection.Width * 0.3
End Sub

QExcelのVBAで画像読込→サイズ変更がしたい。

Excel2003を利用して仕事の工事写真帳を作成していますがVBAでどうしても上手くいかない部分があるので教えていただければと思い投稿しました。
【仕様】工事写真帳は1シート構成、用紙1枚に3枚画像が入り、画像の右側には摘要欄があります。画像を読み込む位置をダブルクリックするとセルのサイズ(写真サイズに結合してあります)を取得して画像サイズを変更して格納します。
【問題点】2枚以上画像を読み込んだ状態で実行すると目的の画像のサイズが変更にならない場合があります。
画像を削除したことで画像の名前が重複するのが原因だというところまではわかるのですが対処方法がわかりません。アドバイスをお願いします。

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

gyo = ActiveCell.Row '画像読込位置の取得
Set scel = Cells(gyo, 3)

scel.Select 'セルサイズの取得
w = Selection.Width
h = Selection.Height

fname = Application.GetOpenFilename _
("画像ファイル,*.gif;*.jpg;*.bmp", 1, "画像ファイルを指定して下さい") '画像読込
If fname = False Then
Exit Sub
End If
ActiveSheet.Pictures.Insert(fname).Select
i% = Selection.Index


Selection.Name = "gazou" & i '画像に名前をつける
Set 画像 = ActiveSheet.Shapes("gazou" & i)


With 画像 '画像のサイズ変更
.LockAspectRatio = False
.Placement = xlFreeFloating
.Placement = xlMove
.Width = w
.Height = h
End With

Range("F" & gyo).Select '摘要欄へ移動

End Sub

Excel2003を利用して仕事の工事写真帳を作成していますがVBAでどうしても上手くいかない部分があるので教えていただければと思い投稿しました。
【仕様】工事写真帳は1シート構成、用紙1枚に3枚画像が入り、画像の右側には摘要欄があります。画像を読み込む位置をダブルクリックするとセルのサイズ(写真サイズに結合してあります)を取得して画像サイズを変更して格納します。
【問題点】2枚以上画像を読み込んだ状態で実行すると目的の画像のサイズが変更にならない場合があります。
画像を削除したことで画...続きを読む

Aベストアンサー

画像にわざわざ名前をつける必要はあるのでしょうか?
(以下は一部抜粋して、少しだけ手を入れました)

Dim pict As String
 ActiveSheet.Pictures.Insert(fname).Select
 pict = Selection.Name
 With ActiveSheet.Shapes(pict) '画像のサイズ変更
  .LockAspectRatio = False
  .Placement = xlFreeFloating
  .Placement = xlMove
  .Width = w
  .Height = h
 End With

これなら画像を繰り返し削除しても大丈夫に思います

QVBAで画像圧縮はできますか?

VBAを使って、
bmp画像ファイルをJPEGやTIFFファイルに圧縮したいのですが
可能でしょうか?

よろしくお願い致します。

Aベストアンサー

可能です。

画像圧縮、変換用のライブラリなんか使えば簡単です。

Google 検索 - 「画像 dll vba jpg bmp」
https://www.google.co.jp/#q=%E7%94%BB%E5%83%8F+dll++vba%E3%80%80jpg+bmp


そういう物を使わずに、自力で実装する事も絶対に出来ないとかって理由は無いです。

Q任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるようにしようとすると、かなり難易度が高くお手上げ状態です。
このプログラムをどのように改修すれば可能になるかお教えください。

Sub 図11()

Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可)", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
Range("B6").Select

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置:アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置:アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = ActiveCell.MergeArea.Height
End With

' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
ActiveCell.Offset(5).Select

Set PIC = Nothing
Next i

' 終了
Application.ScreenUpdating = True

End Sub

よろしくおねがいします。
※マクロはほぼ初心者です。大体がネットからコピペをして使っている程度のレベルです。

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるよう...続きを読む

Aベストアンサー

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトしてください。また、DoEvents も入れておきました。
④は、何も手を付けていません。
コメント・アウトした部分で不要なら削除してください。

'//
Sub 図11R()
 'No. 9024507
 Dim strFilter As String
 Dim Filenames() As Variant
 Dim fName As Variant, ext As String
 Dim PIC As Picture
 Dim k As Long, m As Long
 Dim i As Long, j As Long
 Dim cnt As Long
 Dim FirstRng As Range
 Dim r As Range
 Dim Sel_Folder As Object, Sel_Path As String
 cnt = 0 'カウントの初期値
 '貼り付け最初のセル
 Set FirstRng = Range("A2")
 
  Set Sel_Folder = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "フォルダを選択してください", 5)

  If Not Sel_Folder Is Nothing Then
    Sel_Path = Sel_Folder.Self.Path
  Else
   Exit Sub
  End If
 
 ' 「ファイルを開く」ダイアログでファイル名を取得
 ChDir Sel_Path
' strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
' Filenames = Application.GetOpenFilename( _
' FileFilter:=strFilter, _
' Title:="図の挿入(複数選択可)", _
' MultiSelect:=True)
 fName = Dir("*.*", vbNormal)
 Do While fName <> ""
  If fName <> "." And fName <> ".." Then
   ext = Mid(fName, InStrRev(fName, ".") + 1)
   If InStr(1, "jpg,jpeg,gif,bmp,png", ext, 1) > 0 And Not fName Like "#*" Then
    cnt = cnt + 1
    DoEvents
    ReDim Preserve Filenames(1 To cnt)
    Filenames(cnt) = fName
    ''安全のため(上限を設定)
    If cnt > 100 Then Exit Do
   End If
  End If
  fName = Dir()
 Loop
 If cnt = 0 Then Exit Sub
 
 ' ファイル名をソート
 Call BubbleSort_Str(Filenames, True, vbTextCompare)
 
 '' 貼り付け開始セルを選択
 'Range("B6").Select
 
 ' マクロ実行中の画面描写を停止
 Application.ScreenUpdating = False
 ' 順番に画像を挿入
 k = LBound(Filenames)
 m = UBound(Filenames)
 
 For j = 1 To Int(m / 4) + Abs(m Mod 4 > 0)
  For i = 1 To 4
   Set PIC = ActiveSheet.Pictures.Insert(Filenames(k))
   Set r = FirstRng.Cells(1 + (j - 1) * 2, i)
   
   '-------------------------------------------------------------
   ' 画像の各種プロパティ変更
   '-------------------------------------------------------------
   With PIC
    .Top = r.Top ' 位置:アクティブセルの上側に重ねる
    .Left = r.Left ' 位置:アクティブセルの左側に重ねる
    .Placement = xlMove ' 移動するがサイズ変更しない
    .PrintObject = True ' 印刷する
   End With
   With PIC.ShapeRange
    .LockAspectRatio = msoTrue ' 縦横比維持
    ' 画像の高さをアクティブセルにあわせる
    ' 結合セルの場合でも対応
    .Height = r.MergeArea.Height
   End With
   
   ' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
   ' ActiveCell.Offset(5).Select
   
   Set PIC = Nothing
   k = k + 1
   If k >= m Then Exit For
  Next i
 Next j
 Application.ScreenUpdating = True
 ChDir ThisWorkbook.Path
End Sub

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトし...続きを読む

Qbmp画像をjpegやpng画像に圧縮する方法

http://oshiete.goo.ne.jp/qa/8809275.html

このページでbmp画像をtiff圧縮する方法を教えていただきました。


このプログラムを改良して
jpegやpng画像にも対応したプログラムを作ることはできないでしょうか?

恐らく、

   CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .Guid ' 圧縮方法

というところを書き換えれば、他の形式にも対応できると思うのですが、
CLSIDFromString で検索しても、情報は見つかりませんでした。

どうか教えてください。

Aベストアンサー

#1,2です。KenKen_SP様には失礼して、改造部分のコードを提示させていただきます。Win7Home(64) xl2010(32) で試しています。
出典:http://oshiete.goo.ne.jp/qa/5124395.html

' // Bitmapオブジェクトからファイルへ書き出し
Public Function SaveImageToFile( _
ByVal hBmp As OLE_HANDLE, _
ByVal sFilename As String, _
Optional ByVal sFormat As String = "JPG", _
Optional ByVal nQuarity As Long = 60 _
) As Boolean

'@ sFormat : BMP, JPG, GIF, TIF, PNG
'@ nQuality: 0-100(0:高圧縮低画質, 100:低圧縮高画質, Jpg のみ有効)

Dim sEncoderStr As String
Dim nStatus As Long

Select Case UCase$(sFormat)
Case "JPG": sEncoderStr = ENCODER_JPG
Case "GIF": sEncoderStr = ENCODER_GIF
Case "TIF": sEncoderStr = ENCODER_TIF
Case "PNG": sEncoderStr = ENCODER_PNG
Case Else: sEncoderStr = ENCODER_BMP
End Select

Dim uEncoderParams As EncoderParameters
' Jpeg のクオリティー設定
If UCase$(sFormat) = "JPG" Then
nQuarity = Abs(nQuarity)
If nQuarity > 100 Then nQuarity = 100
uEncoderParams.count = 1
With uEncoderParams.Parameter(0)
.GUID = pvToCLSID(QUALITY_PARAMS)
.TypeAPI = 4 ' Type Long
.Value = VarPtr(nQuarity)
.NumberOfValues = 1
End With
End If

' 保存処理
If UCase$(sFormat) = "JPG" Then
nStatus = GdipSaveImageToFile(hBmp, _
StrPtr(sFilename), _
pvToCLSID(sEncoderStr), _
VarPtr(uEncoderParams))
Else
nStatus = GdipSaveImageToFile(hBmp, _
StrPtr(sFilename), _
pvToCLSID(sEncoderStr), _
ByVal 0&)
End If
SaveImageToFile = CBool(nStatus = 0)
Call GdipDisposeImage(hBmp)

End Function

' // サンプル
Sub Sample()
Dim hBmp As OLE_HANDLE
Dim file1 As String

file1 = GetDesktopPath & "\Hydrangeas.bmp"
' GDI+ を初期化する
If GDIplus_Initialize() = False Then
MsgBox "GDI+ を初期化できません", vbCritical
Exit Sub
End If
'変換元ファイル読込
If GdipCreateBitmapFromFile(ByVal StrPtr(file1), hBmp) <> 0 Then
Gdiplus_Shutdown
Exit Sub
End If

' 保存(JPEG でクオリティー30の場合)
If SaveImageToFile(hBmp, GetDesktopPath & "\sample.jpg", "jpg", 30) = False Then
MsgBox "保存に失敗", vbCritical
Else
MsgBox "保存に成功", vbInformation
End If
' GDI+ を終了させる(必ず呼び出すこと)
Call Gdiplus_Shutdown
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

#1,2です。KenKen_SP様には失礼して、改造部分のコードを提示させていただきます。Win7Home(64) xl2010(32) で試しています。
出典:http://oshiete.goo.ne.jp/qa/5124395.html

' // Bitmapオブジェクトからファイルへ書き出し
Public Function SaveImageToFile( _
ByVal hBmp As OLE_HANDLE, _
ByVal sFilename As String, _
Optional ByVal sFormat As String = "JPG", _
Optional ByVal nQuarity As Long = 60 _
) As Boolean

'@ sFormat : BMP, JPG, GIF, TIF, PNG
'@ nQuality: 0-...続きを読む

Qエクセルに画像(JPG)を取り込む作業を簡単にしたい!!

エクセルに画像(JPG)を取り込むときに、その画像のファイル名をセルに入力するとその画像が取り込めますか??
毎回、挿入から画像のある場所を指定してやっているととっても時間がかかります・・・。
簡単にできる方法はないでしょうか??
マクロがわからないので、やさしく教えてもらえると助かります。

Aベストアンサー

画像挿入ダイアログをマクロで出したいなら、

Sub Test1()
  Application.Dialogs(xlDialogInsertPicture).Show
End Sub

単純に図の挿入ボタンをユーザー設定でツールバーに置いておくのと変わりませんが。

他には、
例えば画像のフルパスを入力したセルを選択し、下記のようなマクロを実行すると画像が挿入されます。

Sub Test2()
Dim pict
On Error Resume Next
  If Dir(ActiveCell.Text) = "" Then Exit Sub
  Set pict = ActiveSheet.Pictures.Insert(ActiveCell.Text)
  pict.Top = ActiveCell.Offset(0, 1).Top
  pict.Left = ActiveCell.Offset(0, 1).Left
End Sub

画像ソフトからのコピー&ペーストは止めた方が良いと思います。
挿入-図と比べて、同じ画像を取り込んでも画像の形式に関係なく出来上がるExcelのファイルサイズがまったく異なってきますので。

> どうしてこんな簡単なことができないのか・・。と思ってしまいます。

Excelは画像管理ソフトじゃないので、そんな機能は必要ないという判断なのでしょう。

画像挿入ダイアログをマクロで出したいなら、

Sub Test1()
  Application.Dialogs(xlDialogInsertPicture).Show
End Sub

単純に図の挿入ボタンをユーザー設定でツールバーに置いておくのと変わりませんが。

他には、
例えば画像のフルパスを入力したセルを選択し、下記のようなマクロを実行すると画像が挿入されます。

Sub Test2()
Dim pict
On Error Resume Next
  If Dir(ActiveCell.Text) = "" Then Exit Sub
  Set pict = ActiveSheet.Pictures.Insert(ActiveCell.Text)
  pict.T...続きを読む

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

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

Aベストアンサー

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

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

QVBAエクセルに貼り付けた画像をセルにあった大きさにしたい(等倍)

エクセル貼り付けた画像をセルにあった大きさにしたいのですが、
その際、縦と横の比率を変更したくありません。

縦と横の比率を変更せず、セルにおさまる最大の大きさで画像のサイズを
変えることは可能でしょうか。

-----------------------------------------------------------------------------
縦と横の比率が関係なく、セルいっぱいのサイズに画像の大きさを変更するVBAは
下記URLから見つけられたのですが、、、、、
http://q.hatena.ne.jp/1240648036

Aベストアンサー

No.1です。

>画像が置いてあるセル上で処理を行う

画像のどこを基準にするか?によってコードは変わってきますが、
画像の左上端のセルにその画像を縦・もしくは横いっぱいに配置するコードにしてみました。

Sub Sample2()
Dim mySp As Shape, myRng As Range
Dim myHgt As Double, myWdt As Double

For Each mySp In ActiveSheet.Shapes
With mySp
Set myRng = .TopLeftCell
myHgt = myRng.Height
myWdt = myRng.Width
.Top = myRng.Top
.Left = myRng.Left
.Height = myHgt
If .Width > myWdt Then
.Width = myWdt
End If
End With
Next mySp
End Sub

こんな感じではどうでしょうか?m(_ _)m

No.1です。

>画像が置いてあるセル上で処理を行う

画像のどこを基準にするか?によってコードは変わってきますが、
画像の左上端のセルにその画像を縦・もしくは横いっぱいに配置するコードにしてみました。

Sub Sample2()
Dim mySp As Shape, myRng As Range
Dim myHgt As Double, myWdt As Double

For Each mySp In ActiveSheet.Shapes
With mySp
Set myRng = .TopLeftCell
myHgt = myRng.Height
myWdt = myRng.Width
.Top = myRn...続きを読む

Qエクセル(2013)VBA-図の縦横比を変えずにセルにおさまる最大限の大きさにする

エクセル(2013)VBAを使って、画像を挿入し、挿入した画像を図として貼付けしているのですが、
その後、貼り付けた図をセルにおさまる最大限の大きさ(縦横比は変更しない)
に変更したいのですが、どのようなコードを書けば良いのかご教授頂きたいです。

今出来ているマクロは、ネットからコピーしてきたものの為、
私には知識が足りずカスタマイズができませんでした。。。
似たような質問があったのですが、そちらも私には理解できませんでした。。

以下が現在のコードです。”【質問】”と記載した箇所に入れるコードを教えて頂きたいです。

※画像を全て貼り付けてから、全ての画像のサイズをセルに合わせる。という方法は
 避けたく、都度取り込んだ画像のサイズを変えるようにしたいです。

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

Sub 画像とファイル名書き出し()

Dim fName As Variant
Dim i As Long
Dim Pict As picture
Dim mySp As Shape, myRng As Range
Dim myHgt As Double, myWdt As Double

'ファイル選択
fName = Application.GetOpenFilename("画像 ,*.emf; *.wmf; *.jpg; *.jpeg; *.jfif; *.jpe; *.png; *.bmp; *.dib; *.rle; *.gif; *.emz; *.wmz; *.pcz; *.tif; *.tiff; *.eps; *.pct; *.pict; *.wpg", MultiSelect:=True)

If IsArray(fName) Then
Application.ScreenUpdating = False
'配列に格納されたファイル名をソート
BubbleSort fName, True
For i = 1 To UBound(fName)
Set Pict = ActiveSheet.Pictures.Insert(fName(i))


With Pict
.TopLeftCell = ActiveCell
.ShapeRange.LockAspectRatio = msoTrue
.Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False


' <<<【質問】ここでセルにおさまる最大限の大きさ(縦横比は固定)に変更したいです>>>
'
'
'
'
'

ActiveCell.offset(0, 1) = fName(i) '保存場所&ファイル名
ActiveCell.offset(0, 2) = Dir(fName(i)) 'ファイル名
End With
ActiveCell.offset(1, 0).Activate
Application.StatusBar = "処理中:" & i & "/" & UBound(fName) & "枚目"

Next i
End If
With Application
.StatusBar = False
.ScreenUpdating = True
End With

Set Pict = Nothing
If i < 1 Then
MsgBox "0枚の画像を挿入しました", vbInformation

Else
MsgBox i - 1 & "枚の画像を挿入しました", vbInformation
End If

End Sub
'値の入替え
Public Sub Swap(ByRef Dat1 As Variant, ByRef Dat2 As Variant)

Dim varBuf As Variant
varBuf = Dat1
Dat1 = Dat2
Dat2 = varBuf

End Sub

'配列のバブルソート
Public Sub BubbleSort(ByRef aryDat As Variant, _
Optional ByVal SortAsc As Boolean = True)

Dim i As Long
Dim j As Long
For i = LBound(aryDat) To UBound(aryDat) - 1
For j = LBound(aryDat) To LBound(aryDat) + UBound(aryDat) - i - 1
If aryDat(IIf(SortAsc, j, j + 1)) > aryDat(IIf(SortAsc, j + 1, j)) Then
Call Swap(aryDat(j), aryDat(j + 1))
End If
Next j
Next i

End Sub

エクセル(2013)VBAを使って、画像を挿入し、挿入した画像を図として貼付けしているのですが、
その後、貼り付けた図をセルにおさまる最大限の大きさ(縦横比は変更しない)
に変更したいのですが、どのようなコードを書けば良いのかご教授頂きたいです。

今出来ているマクロは、ネットからコピーしてきたものの為、
私には知識が足りずカスタマイズができませんでした。。。
似たような質問があったのですが、そちらも私には理解できませんでした。。

以下が現在のコードです。”【質問】”と記載した箇...続きを読む

Aベストアンサー

こんにちは、以下のコードをコメント部にいれてみて下さい。

'ここから
'この行はとりあえずコメントにしました
'''''ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False

'変数設定はループの外(上の変数設定の部分)でして下さい
dim wWIDTH as long
dim wHIGHT as long
dim wRITU as double
dim MyShape as shape
dim oPIC as stdole.IPictureDisp

cells(i,1).select '<--- 画像を貼り付けるセルを選択しています

Set oPIC=LoadPicture(fName(i))

'指定したセルの高さに合わせる場合(今回は高さに合わせました)
wHIGHT=Selection.height 'セルの高さ
wRITU =wHIGHT/oPIC.height '比率=セルの高さ / 実画像の高さ
wWIDTH=int(oPIC.width*wRITU)

'指定したセルの横幅に合わせる場合
'' wWIDTH=Selection.width 'セルの幅
'' wRITU =wWIDTH/opic.width '比率=セルの幅 / 実画像の幅
'' wHIGHT=int(oPIC.height*wRITU)

Set MyShape=ActiveSheet.Shapes.AddPicture(Filename:=fName(i),LinkToFile:=False,SaveWithDocument:=True, _
Left:=Selection.Left,Top:=Selection.Top,Width:=wWIDTH,Height:=wHIGHT)
'ここまで

では頑張ってください

こんにちは、以下のコードをコメント部にいれてみて下さい。

'ここから
'この行はとりあえずコメントにしました
'''''ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False

'変数設定はループの外(上の変数設定の部分)でして下さい
dim wWIDTH as long
dim wHIGHT as long
dim wRITU as double
dim MyShape as shape
dim oPIC as stdole.IPictureDisp

cells(i,1).select '<--- 画像を貼り付けるセルを選択しています

Set oPIC=LoadPicture(fName(i))

'指定したセ...続きを読む

QEXCEL VBAで計算値を四捨五入、切り上げ、切捨てする方法

ネットで探してみたのですが、計算結果を四捨五入して特定のセルを
返すにはどうしたらいいのでしょうか?

Sub hokangosa()

Dim ZPS As Double
Dim ZPOS As Double
Dim DMN As Double
MsgBox (" >>> 補間誤差自動計算 <<< ")
MsgBox (" >>> 初期値入力します <<< ")
ZPS = InputBox(">>> ステップを入力してください<<<")
ZPOS = Sheet1.Cells(22, 4).Value
DMN = ZPOS / ZPS
Sheet1.Cells(23, 6).Value = DMN
End Sub

ここでDMNの値を四捨五入したいです。

またこれとは別に切上げ、切捨ても教えていただけるとありがたいです。

Aベストアンサー

DMN = Application.WorksheetFunction.Round(ZPOS / ZPS, 0)
で、四捨五入
DMN = Application.RoundDown(ZPOS / ZPS, 0)
で切り捨て
DMN = Application.RoundUp(ZPOS / ZPS, 0)
で切り上げです。

引数で、対象桁を変更できます。


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

人気Q&Aランキング