| |
▼ゆらり さん：
>画像ファイルを開いた後に、表示ファイルがアクティブの状態でSendkeyステートメントを使用して回転させるつもりでしたが、不可能ですか？
そういう手段は安定性がないのであまり考えない方がよいと思います。
外部ソフトに複数ファイルを一括Rotateするバッチ機能があれば、
ExcelVBAでマクロを組む必要はない。---これは前回のアドバイスですが、
もしそういう機能が無いのなら、
このスレッドの最初のぼくの（要件をかんちがいした）処理方法に戻って
こちらの方法を考えてもいいんじゃないかと思います。
というのも、
Excelで画像をシートに貼り付けて回転まではできるのですから、
あとはこれを元の画像形式で保存すればいいだけですので。。。
幸い shira さんが2005年にmougに投稿された（これ以前にもあったかも
知れませんが、ぼくが教えてもらったのはこのときでした）GDI の機能を使う
図の保存コードがあるので、それを使わせていただくことにすれば
話は簡単になります。
以下を新規モジュールに貼り付け、下のほうの
> Sub 画像ファイル回転保存90()
を実行してみてください。
このプロシージャは 画像を90°回転させ、元のファイル名に#90を
追加して保存し直すものです。
'--------
Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Declare Function GdiplusStartup Lib "gdiplus" _
(token As Long, pInput As GdiplusStartupInput, _
pOutput As Any) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" _
(ByVal token As Long)
Private Declare Function GdipDisposeImage Lib "gdiplus" _
(ByVal Image As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" _
(ByVal hbm As Long, ByVal hPal As Long, _
bitmap As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" _
(ByVal Image As Long, filename As Any, _
clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" _
(lpsz As Any, pClsid As GUID) As Long
Const CLSID_PNG_CODEC = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Const CLSID_JPG_CODEC = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Const CLSID_BMP_CODEC = "{557cf400-1a04-11d3-9a73-0000f81ef32e}"
Const CLSID_GIF_CODEC = "{557cf402-1a04-11d3-9a73-0000f81ef32e}"
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal uFormat As Long) As Long
Const CF_BITMAP = 2
Private Declare Function CopyImage Lib "user32" _
(ByVal hImage As Long, ByVal uType As Long, _
ByVal cxDesired As Long, ByVal cyDesired As Long, _
ByVal fuFlags As Long) As Long
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
'--------------------------------------------------------------------------------
'// クリップボードにコピーされたBMP を 元の形式で保存
Function SaveBmpClipAs(ByVal savePath As String, _
Style As String) As Boolean
Dim udtInput As GdiplusStartupInput
Dim EncoderId As GUID
Dim lngToken As Long
Dim pBitmap As Long
Dim hbmp As Long
Dim ClsID As String
If OpenClipboard(0) Then
hbmp = CopyImage(GetClipboardData(CF_BITMAP), _
IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
CloseClipboard
End If
If hbmp = 0 Then MsgBox "Failed to get hBmp": Exit Function
udtInput.GdiplusVersion = 1
If GdiplusStartup(lngToken, udtInput, ByVal 0&) = 0 Then
If GdipCreateBitmapFromHBITMAP(hbmp, 0, pBitmap) = 0 Then
Select Case LCase$(Style)
Case "jpg", "jpeg"
ClsID = CLSID_JPG_CODEC
Case "png"
ClsID = CLSID_PNG_CODEC
Case "bmp"
ClsID = CLSID_BMP_CODEC
End Select
CLSIDFromString ByVal StrPtr(ClsID), EncoderId
If GdipSaveImageToFile( _
pBitmap, ByVal StrPtr(savePath & ""), _
EncoderId, ByVal 0&) = 0 Then
SaveBmpClipAs = True
End If
GdipDisposeImage pBitmap
End If
GdiplusShutdown lngToken
End If
DeleteObject hbmp
End Function
'--------
Sub 画像ファイル回転保存90()
Dim myPicFiles
Dim saveFormat As String
Dim m As Long
'回転する画像ファイルの指定(複数可)
myPicFiles = Application.GetOpenFilename( _
"BMP or JPGファイル,*.Bmp;*.jpg;*.jpeg;*.Png", _
MultiSelect:=True)
If VarType(myPicFiles) = vbBoolean Then Exit Sub
Dim picName
Range("A1").Select
Application.ScreenUpdating = False
For Each picName In myPicFiles
With ActiveSheet.Pictures.Insert(picName)
.ShapeRange.IncrementRotation 90#
.CopyPicture Format:=xlBitmap
m = InStrRev(picName, ".")
saveFormat = Mid$(picName, m + 1)
SaveBmpClipAs Replace(picName, ".", "#90."), _
Style:=saveFormat
.Delete
End With
Next
Application.ScreenUpdating = True
End Sub
|
|
kanabun
- 13/5/28(火) 11:11 -
