EXCELで以下のことをができるＶＢＡを作成しようと思っています。

質問

EXCELで以下のことをができるＶＢＡを作成しようと思っています。

・１シートにサムネイルを100枚程度を貼り付ける。
・デェフォルトサイズの画像をフォルダに保存する。
・サムネイル名のリンクからフォルダに保存したデェフォルトサイズの画像見れるようにする。

デェフォルトサイズの画像ですと、デジカメなどサイズが大きい写真が多いため、
EXCELのブックが重くなり不便です。

そのため、VBAでImageMagicのように画像を小さく加工し、
ファイルサイズを変更した後に、シートに貼り付けたいと考えています。

DLLを使用するやら何やらよい方法はございませんでしょうか。

回答No.4

mitarashi · ベストアンサー

そういえば、形式を指定して貼り付けで、JPEGが選択できる場合がある事を思い出しました。
縮小した画像のコピーを単純に
Selection.Copy
に替えて、貼り付ける方も
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:= _
False
とすると、ファイルサイズはさらに1/2程度になりました。処理時間は大差ありません。ご参考まで。

回答No.3

mitarashi

お久しぶりですが、たまたま別件で調べておりました。APIなど持ち出さずに行う例です。70数Mが、4M弱にしかなりませんでした。実行時間は、70数秒～50数秒です。ファイル数800個弱。当方xl2000なので、その機能がありませんが、「圧縮」という機能を用いればもっと小さくなるのかも？
Sub test()
Dim FSO As Object
Dim fileList As Object
Dim myfile As Object
Dim i As Long, j As Long
Dim startTime As Long

startTime = GetTickCount
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.GetFolder("C:\Documents and Settings\??????")
Set fileList = .Files
End With
i = 1: j = 1
Application.ScreenUpdating = False
For Each myfile In fileList
If UCase(FSO.GetExtensionName(myfile.Path)) = "JPG" Then
Sheets(1).Activate
ActiveSheet.Pictures.Insert(myfile.Path).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
'このへんのサイズ、縮小率はお好みで
If Selection.ShapeRange.Height > Selection.ShapeRange.Width Then
Selection.ShapeRange.Height = 40
Selection.ShapeRange.Width = 30
Else
Selection.ShapeRange.Height = 30
Selection.ShapeRange.Width = 40
End If
' Selection.ShapeRange.ScaleWidth 0.2, msoFalse, msoScaleFromTopLeft
' Selection.ShapeRange.ScaleHeight 0.2, msoFalse, msoScaleFromTopLeft
'xlBitmapの方が若干ファイルサイズが小さいですが、2007では、xlPictureしか有効でないという情報もありますのでコメントアウトして置いておきます
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap 'xlPicture
Sheets(2).Activate
Cells(i, j).Select
' ActiveSheet.PasteSpecial Format:="図 (拡張メタファイル)", Link:=False, _
' DisplayAsIcon:=False
ActiveSheet.PasteSpecial Format:="ビットマップ", Link:=False, DisplayAsIcon:=False
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=myfile.Path
Sheets(1).Activate
Selection.Delete
i = i + 1
If i > 20 Then
i = 1
j = j + 1
End If
End If
Next myfile
Application.ScreenUpdating = True
MsgBox "ファイル数:" & CStr(fileList.Count) & vbCrLf & _
"所要時間:" & CStr(GetTickCount - startTime)
Set FSO = Nothing
End Sub

回答No.2

mitarashi

#1です。BMP形式だとファイルサイズが画期的には小さくならないみたいですね。
こちらをお使い下さい。
http://okwave.jp/qa/q5647625.html
試しにやってみました。ファイル一個毎にGDI+の初期化、終了を行っているので、効率は良くないと
思いますが、450個位のファイル処理が30～18秒程度(PentiumM 1.3G Note)でした。30M→0.9M程度のワークブックサイズです。なお、一時ファイルを使用せず、クリップボードから貼り付ける事も可能だと思いますが、JPEGファイルから取り込んだ方がファイルが小さくなると聞いた事があるような。画像の縦長、横長の混在等あると、お気に召す様な結果にはならないと思いますが、骨組みという事でご参考まで。なお、xl2000のコードです。
Public Declare Function GetTickCount Lib "KERNEL32" () As Long

Sub test()
Dim FSO As Object
Dim fileList As Object
Dim myfile As Object
Dim i As Long, j As Long
Dim startTime As Long

startTime = GetTickCount
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.GetFolder("C:\Documents and Settings\??????")
Set fileList = .Files
End With
i = 1: j = 1
Application.ScreenUpdating = False
For Each myfile In fileList
If UCase(FSO.GetExtensionName(myfile.Path)) = "JPG" Then
Call resizePicture(myfile.Path, "C:\test.jpg", scalerate:=20, _
InterpolationMode:=InterpolationModeHighQualityBicubic, _
jpegQuality:=10)
Cells(i, j).Activate
ActiveSheet.Pictures.Insert("C:\test.jpg").Select
Selection.Height = ActiveCell.Height
Selection.Width = ActiveCell.Width
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.item(1), Address:=myfile.Path
i = i + 1
If i > 20 Then
i = 1
j = j + 1
End If
End If
Next myfile
Application.ScreenUpdating = True
MsgBox "ファイル数:" & cstr(fileList.count) & vbcrlf & _
"所要時間:" & CStr(GetTickCount - startTime)
Set FSO = Nothing
End Sub

補足

難解です、サンプルのワークブック等はございませんでしょうか。

回答No.1

mitarashi

GDIplusのAPIを用いて、サムネイル画像を作成する例を回答しています。ご参考まで。
http://okwave.jp/qa/q5640681.html