


'ЧͼƬ
Public Function CreateFromPicture(ByVal AnyPic As Long, MPC As MENUPICTURE, Optional ByVal Width As Long, Optional ByVal Height As Long) As Long
Dim Bmp As BITMAP, nDC As Long, cDC As Long, mDC As Long, hDc As Long, DEV As DEVMODE
Dim lhBmpOld As Long, hBmp As Long, Rtn As Long, pWidth As Integer, pHeight As Integer
   GetObject AnyPic, Len(Bmp), Bmp
   pWidth = Bmp.bmWidth
   pHeight = Bmp.bmHeight
  'Create Picture
  mDC = CreateDC("DISPLAY", vbNullString, vbNullString, DEV) 'DEV = 0 Nohting VBNULL ...
  hDc = CreateCompatibleDC(mDC)
  If Width <> 0 Or Height <> 0 Then
    If Width < Bmp.bmWidth Then Width = Bmp.bmWidth
    If Height < Bmp.bmHeight Then Height = Bmp.bmHeight
    hBmp = CreateCompatibleBitmap(mDC, Width, Height)
     Else
     Width = Bmp.bmWidth: Height = Bmp.bmHeight
    hBmp = CreateCompatibleBitmap(mDC, Width, Height)
   End If
  Rtn = SelectObject(hDc, hBmp)
   If Rtn = 0 Then
     DeleteObject hBmp
     Else
     pWidth = Width
     pHeight = Height
   End If
  DeleteDC mDC
  'Create Picture END
   nDC = CreateDC("DISPLAY", vbNullString, vbNullString, DEV)
   cDC = CreateCompatibleDC(nDC)
    lhBmpOld = SelectObject(cDC, AnyPic)
     BitBlt hDc, 0, 0, Bmp.bmWidth, Bmp.bmHeight, cDC, 0, 0, vbSrcCopy
    SelectObject cDC, lhBmpOld
   DeleteDC cDC
   DeleteDC nDC
   DeleteObject hBmp
   DeleteObject lhBmpOld
  With MPC
    If hDc <> 0 Then
     .hDc = hDc
       Else
     .hDc = hDc
    End If
     .Height = pHeight
     .Width = pWidth
     .hSize = Len(MPC)
     .hPic = AnyPic
  End With
  CreateFromPicture = MPC.hSize
 Exit Function
ErrX:
CreateFromPicture = -1
End Function




