GDIplusCODE


Sub displayshapesonform2()
  Dim myImage As Image
  Dim hBmp As Long, hdc As Long
  Dim hComDC As Long
  Dim ret As Long
  Dim r As RECT
  Dim hemf As Long
  Dim mh As ENHMETAHEADER '取得結果のメタファイルヘッダ
  Dim readEMFsize As SIZEL
  Dim hemf2 As Long
  
  'Clipboardからemfを取得
  Selection.Copy
  If OpenClipboard(0) Then
    hemf = GetClipboardData(CF_ENHMETAFILE)
    ' ハンドルを複製してから使用する
    hemf = CopyEnhMetaFile(hemf, vbNullString)
    CloseClipboard
  End If
　'上記をコメントアウトして、下記を生かすと、ファイルから読み込んで表示できる
　'hemf = GetEnhMetaFile("c:\test.emf")

  If hemf = 0 Then
    MsgBox "emf取得に失敗"
    Exit Sub
  End If
  '   ヘッダの取得
  GetEnhMetaFileHeader hemf, Len(mh), mh
  With mh
    readEMFsize.cx = .rclBounds.Right - .rclBounds.Left
    readEMFsize.cy = .rclBounds.Bottom - .rclBounds.Top
  End With
  UserForm2.Show vbModeless
  Set myImage = UserForm2.Image1
  Call resizeForm(UserForm2, readEMFsize)
  With UserForm2.Image1
    .Height = UserForm2.InsideHeight
    .Width = UserForm2.InsideWidth
    .Top = 0
    .Left = 0
  End With
  myImage.Picture = Nothing
  myImage.PictureAlignment = fmPictureAlignmentTopLeft
  myImage.PictureSizeMode = fmPictureSizeModeClip
  '白のbmpをロードする。
  myImage.Picture = LoadPicture("c:\white.bmp")
  hBmp = myImage.Picture.handle
  hdc = GetDC(0)
  hComDC = CreateCompatibleDC(hdc)
  ret = ReleaseDC(0, hdc)
  ret = SelectObject(hComDC, hBmp)
  r.Top = 0
  r.Left = 0
  r.Bottom = UserForm2.Image1.Height * 96 / 72
  r.Right = UserForm2.Image1.Width * 96 / 72
'  hemf = GetEnhMetaFile("c:\temp.emf") 'ファイルから読むとき
  Call PlayEnhMetaFile(hComDC, hemf, r)
  ret = DeleteDC(hComDC)
  Set myImage = Nothing
End Sub

'試行錯誤でユーザーフォームの有効寸法をグラフィックのサイズに合わせる
Private Sub resizeForm(myForm As Object, picSize As SIZEL)
  myForm.Width = picSize.cx * 72 / 96
  myForm.Height = picSize.cy * 72 / 96
  Do
    myForm.Width = myForm.Width + 0.25
  Loop Until myForm.InsideWidth >= picSize.cx * 72 / 96
  Do
    myForm.Height = myForm.Height + 0.25
  Loop Until myForm.InsideHeight >= picSize.cy * 72 / 96
End Sub

'クリップボードのメタファイルの画像寸法を取得
Private Function readEMFsize(Optional hemf As Long = 0) As SIZEL
'  Dim hEmf As Long '拡張メタファイルのハンドル
  Dim mh As ENHMETAHEADER '取得結果のメタファイルヘッダ
  Dim emfWidth As Long, emfHeight As Long
  
  If hemf = 0 Then
    Selection.Copy
    If OpenClipboard(0) Then
      hemf = GetClipboardData(CF_ENHMETAFILE)
      ' ハンドルを複製してから使用する
      hemf = CopyEnhMetaFile(hemf, vbNullString)
      CloseClipboard
    End If
    If hemf = 0 Then
      MsgBox "emf取得に失敗"
      Exit Function ' 失敗
    End If
  End If
   'ヘッダの取得
  GetEnhMetaFileHeader hemf, Len(mh), mh
  With mh
    readEMFsize.cx = .rclBounds.Right - .rclBounds.Left
    readEMFsize.cy = .rclBounds.Bottom - .rclBounds.Top
  End With
  DeleteEnhMetaFile hemf
End Function
AutoShapeをUserformに表示（その２）。Imageにplayenhmetafile
