Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7933 / 76734 ←次へ | 前へ→

【74382】Re:Runメソッドは失敗しました。
発言  kanabun  - 13/5/28(火) 11:11 -

引用なし
パスワード
   ▼ゆらり さん:

>画像ファイルを開いた後に、表示ファイルがアクティブの状態で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

3 hits

【74370】Runメソッドは失敗しました。 ゆらり 13/5/27(月) 14:49 質問
【74371】Re:Runメソッドは失敗しました。 kanabun 13/5/27(月) 17:13 発言
【74372】Re:Runメソッドは失敗しました。 ゆらり 13/5/27(月) 18:50 発言
【74374】Re:Runメソッドは失敗しました。 kanabun 13/5/27(月) 20:09 発言
【74375】Re:Runメソッドは失敗しました。 kanabun 13/5/27(月) 20:24 発言
【74376】Re:Runメソッドは失敗しました。 ゆらり 13/5/27(月) 20:59 発言
【74382】Re:Runメソッドは失敗しました。 kanabun 13/5/28(火) 11:11 発言
【74387】Re:Runメソッドは失敗しました。 kanabun 13/5/28(火) 19:38 発言

7933 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free