GDIplusCODE


	
'******************************************************************************
'* 【参考元】
'*   Microsoft Support
'*   画面、フォーム、ウィンドウを取り込んで印刷する方法
'*   文書番号: 161299
'*   http://support.microsoft.com/kb/161299/ja
'******************************************************************************

Option Explicit
Option Base 0

Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type

Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY  ' Enough for 256 colors.
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type PicBmp
   Size As Long
   Type As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Private Const vbPicTypeBitmap As Long = 1
Private Const vbSrcCopy As Long = &HCC0020

Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

'追加 ======================================

Private Type POINT
x As Long
y As Long
End Type

Private Const PICTYPE_BITMAP = 1
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINT) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long

'Webカメラ画像表示アプリのウィンドウのクライアント領域をエクセルワークシートにペースト
'http://kougaku-navi.net/backyard/　で公開して下さっている、CameraViewer使用例
Public Sub CaptureCameraViewerWindow()
    Dim lngRet As Long
    Dim strWindowText As String
    Dim lngHWnd As Long
    Dim myPoint As POINT
    Dim lngWnd As Long
    Dim RectActive As RECT
    Dim RectForm As RECT
    Dim myPic As Picture
    
    Const xSpan As Double = 5
    Const ySpan As Double = 5
    
    Application.ScreenUpdating = False
    '取得するウィンドウのキャプションを設定します
    'この名前はCameraViewerの場合なので、実際のアプリケーションに合わせる必要があります
    strWindowText = "Capture [0]"
    lngWnd = FindWindow(vbNullString, strWindowText)
    If lngWnd = 0 Then Exit Sub
    
    lngRet = GetWindowRect(lngWnd, RectForm)
    With myPoint
      .x = RectForm.Left
      .y = RectForm.Top
    End With
    lngRet = ScreenToClient(lngWnd, myPoint)
    lngRet = GetClientRect(lngWnd, RectActive)
    '自分でクライアント領域取り込み用に改造したが、MSのサイトのコードにも含まれていた(^^;)
    lngRet = CaptureWindow2(lngWnd, False, Abs(myPoint.x), Abs(myPoint.y), RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)

    With ActiveSheet
      .Paste
      ' .Shapes(.Shapes.Count)で、Shapeとして扱っていたが、Shape->Pictureがスマートにいかないので方針転換
      Set myPic = .DrawingObjects(.DrawingObjects.Count)
      'Activecellの中央に寸法を合わせて（Optionで余白も設定して）貼り付ける
      '3番目の引数はJPEG形式で貼り付けてファイル容量の巨大化防止
      arrangeToMergeCell ActiveCell, myPic, True, 5, 5
    End With
    ActiveCell.Activate
    Application.ScreenUpdating = True
End Sub

'************************************************************
'
' 引数　貼り付け対象Range(結合セル可),対象画像(Shape型),Jpeg貼り付け有無Flag、余白ｘ,余白y
'
'************************************************************

Sub arrangeToMergeCell(targetcell As Range, targetPic As Picture, shrinkFlag As Boolean, Optional xSpan As Double = 0, Optional ySpan As Double = 0)
  Dim targetArea As Range
  Dim xOffset As Double, yOffset As Double
  Dim xScale As Double, yScale As Double, myScale As Double
  Dim mergeHeight As Double, mergeWidth As Double
  Dim i As Long, j As Long
  Dim currentSh As Worksheet
   
  Application.ScreenUpdating = False
  Set currentSh = ActiveSheet
  
  Set targetArea = targetcell.MergeArea
  With targetArea
    For i = 1 To .Rows.Count
      mergeHeight = mergeHeight + .Rows(i).Height
    Next i
    For j = 1 To .Columns.Count
      mergeWidth = mergeWidth + .Columns(j).Width
    Next j
  End With
  
  xScale = (mergeWidth - xSpan * 2) / targetPic.Width
  yScale = (mergeHeight - ySpan * 2) / targetPic.Height
  If yScale < xScale Then
    myScale = yScale
  Else
    myScale = xScale
  End If
  
  'ここはShapeにして楽な道にに走る
  targetPic.ShapeRange.ScaleWidth myScale, msoTrue, msoScaleFromTopLeft
  
  'JPEGでの貼り付けTrueの時
  If shrinkFlag = True Then
    targetcell.Parent.Activate
    targetcell.Activate
    targetPic.Cut
    ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
    Set targetPic = Selection
    currentSh.Activate
  End If
  With targetPic
    .Left = targetcell.Left + mergeWidth / 2 - .Width / 2
    .Top = targetcell.Top + mergeHeight / 2 - .Height / 2
   End With
   Application.ScreenUpdating = True
 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

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureWindow
'    - Captures client area of the specified window. 怪しい英語
'
' hWndSrc
'    - Handle to the window to be captured.
'
' Client
'    - If True CaptureWindow captures from the client area of the
'      window.
'    - If False CaptureWindow captures from the entire window.
'
' LeftSrc, TopSrc, WidthSrc, HeightSrc
'    - Specify the portion of the window to capture.
'    - Dimensions need to be specified in pixels.
'
' Returns
'    - 改造：Error Code
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Function CaptureWindow2(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Long
  On Error GoTo errHandle
  Dim lngRet As Long
  
  ' Depending on the value of Client get the proper device context.
  Dim hDCSrc As Long
  hDCSrc = IIf(Client, GetDC(hWndSrc), GetWindowDC(hWndSrc))
  
  ' Create a memory device context for the copy process.
  Dim hDCMemory As Long
  hDCMemory = CreateCompatibleDC(hDCSrc)
  
  ' Create a bitmap and place it in the memory DC.
  Dim hBmp As Long, hBmpPrev As Long
  hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
  hBmpPrev = SelectObject(hDCMemory, hBmp)
  
  ' Get screen properties.
  Dim RasterCapsScrn As Long, HasPaletteScrn As Long, PaletteSizeScrn As Long
  RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)   ' Raster capabilities.
  HasPaletteScrn = RasterCapsScrn And RC_PALETTE       ' Palette support.
  PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of palette.
  
  ' If the screen has a palette make a copy and realize it.
  Dim hPal As Long, hPalPrev As Long, LogPal As LOGPALETTE
  If HasPaletteScrn And (PaletteSizeScrn = 256) Then
      ' Create a copy of the system palette.
      LogPal.palVersion = &H300
      LogPal.palNumEntries = 256
      lngRet = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
      hPal = CreatePalette(LogPal)
      ' Select the new palette into the memory DC and realize it.
      hPalPrev = SelectPalette(hDCMemory, hPal, 0)
      lngRet = RealizePalette(hDCMemory)
  End If
  
  ' Copy the on-screen image into the memory DC.
  lngRet = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
  
  ' Remove the new copy of the  on-screen image.
  hBmp = SelectObject(hDCMemory, hBmpPrev)
  
  ' If the screen has a palette get back the palette that was
  ' selected in previously.
  If HasPaletteScrn And (PaletteSizeScrn = 256) Then
      hPal = SelectPalette(hDCMemory, hPalPrev, 0)
  End If
  
  ' Release the device context resources back to the system.
  lngRet = DeleteDC(hDCMemory)
  lngRet = ReleaseDC(hWndSrc, hDCSrc)
  
'改造：Pictureを生成せず、クリップボードにコピーする
  If OpenClipboard(0&) <> 0 Then
      EmptyClipboard
      SetClipboardData CF_BITMAP, hBmp
      CloseClipboard
  End If
errHandle:
  lngRet = Err.Number
End Function
Webカメラの画像をワークシートに貼り付け
