Option Explicit

Public Type POINTAPI
   X As Long
   Y As Long
End Type

Private Enum BOOL
   FALSE_BOOL = 0
   TRUE_BOOL = 1
End Enum

Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" ( _
   ByVal lpDriverName As String, ByVal lpDeviceName As String, _
   ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As BOOL

Private Enum DeviceCapIndex
   HORZSIZE = 4           '  Horizontal size in millimeters
   VERTSIZE = 6           '  Vertical size in millimeters
   HORZRES = 8            '  Horizontal width in pixels
   VERTRES = 10           '  Vertical width in pixels
   LOGPIXELSX = 88        '  Logical pixels/inch in X
   LOGPIXELSY = 90        '  Logical pixels/inch in Y
End Enum
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nIndex As DeviceCapIndex) As Long

Private Const TWIPS_PER_INCH = 1440&

Public Function TwipsPerPixelX() As Long
 Dim hicDisplay As Long
 hicDisplay = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
 TwipsPerPixelX = TWIPS_PER_INCH \ GetDeviceCaps(hicDisplay, LOGPIXELSX)
 DeleteDC hicDisplay
End Function

Public Function TwipsPerPixelY() As Long
 Dim hicDisplay As Long
 hicDisplay = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
 TwipsPerPixelY = TWIPS_PER_INCH \ GetDeviceCaps(hicDisplay, LOGPIXELSY)
 DeleteDC hicDisplay
End Function

#Const PRAGMA_SAFE = False

Option Explicit


Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   pvDest As Any, pvSource As Any, ByVal cBytes As Long)
'Private Declare Function GetMem4 Lib "msvbvm60" ( _
   ByVal pSrc As Long, Dst As Long) As Long
'Private Declare Function PutMem4 Lib "msvbvm60" ( _
   ByVal pDst As Long, ByVal NewValue As Long) As Long


Private Enum BOOL
   FALSE_BOOL = 0
   TRUE_BOOL = 1
End Enum

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

Private Declare Function GetClientRect Lib "user32" ( _
   ByVal hWnd As Long, lpRect As RECT) As BOOL
Private Declare Function GetWindowRect Lib "user32" ( _
   ByVal hWnd As Long, lpRect As RECT) As BOOL

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function GetDC Lib "user32" ( _
   ByVal hWnd As Long) As Long
Private Declare Function GetWindowDC Lib "user32" ( _
   ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
   ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" ( _
   ByVal lpDriverName As String, ByVal lpDeviceName As String, _
   ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
   ByVal hDC As Long) As BOOL

Private Declare Function SelectObject Lib "gdi32" ( _
   ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
   ByVal hObject As Long) As BOOL

Private Enum DeviceCapIndex
   HORZSIZE = 4           '  Horizontal size in millimeters
   VERTSIZE = 6           '  Vertical size in millimeters
   HORZRES = 8            '  Horizontal width in pixels
   VERTRES = 10           '  Vertical width in pixels
   LOGPIXELSX = 88        '  Logical pixels/inch in X
   LOGPIXELSY = 90        '  Logical pixels/inch in Y
End Enum
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nIndex As DeviceCapIndex) As Long


Private Type BITMAP '24 bytes
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type

Private Enum BitmapCompressionType
   BI_RGB = 0
   BI_RLE8 = 1
   BI_RLE4 = 2
   BI_BITFIELDS = 3
   BI_JPEG = 4
   BI_PNG = 5
End Enum

Private Type BITMAPINFOHEADER '40 bytes
   biSize As Long
   biWidth As Long
   biHeight As Long
   biPlanes As Integer
   biBitCount As Integer
   biCompression As BitmapCompressionType
   biSizeImage As Long
   biXPelsPerMeter As Long
   biYPelsPerMeter As Long
   biClrUsed As Long
   biClrImportant As Long
End Type

Private Type RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbReserved As Byte
End Type

Private Type BITMAPINFO
   bmiHeader As BITMAPINFOHEADER
   bmiColors As RGBQUAD
End Type

Private Type DIBSECTION
   dsBm As BITMAP
   dsBmih As BITMAPINFOHEADER
   dsBitfields(0 To 2) As Long
   dshSection As Long
   dsOffset As Long
End Type

Private Declare Function CreateDIBSection Lib "gdi32" ( _
   ByVal hDC As Long, pbmi As BITMAPINFO, ByVal iUsage As Long, _
   pBits As Any, ByVal hSection As Long, ByVal dwOffset As Long) As Long
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs


Private Declare Function SetPixel Lib "gdi32" ( _
   ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, _
   ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As BOOL
Private Declare Function LineTo Lib "gdi32" ( _
   ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As BOOL
Private Declare Function Rectangle Lib "gdi32" ( _
   ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, _
   ByVal X2 As Long, ByVal Y2 As Long) As BOOL
Private Declare Function Ellipse Lib "gdi32" ( _
   ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, _
   ByVal X2 As Long, ByVal Y2 As Long) As BOOL
Private Declare Function Polyline Lib "gdi32" ( _
   ByVal hDC As Long, lppt As POINTAPI, ByVal cPoints As Long) As BOOL

Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Declare Function BitBlt Lib "gdi32" ( _
   ByVal hdcDst As Long, ByVal xDst As Long, ByVal yDst 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 BOOL


Public Enum PenStyle
   psSolid = 0
   psDash = 1                    '  -------
   psDot = 2                     '  .......
   psDashDot = 3                 '  _._._._
   psDashDotDot = 4              '  _.._.._
   psNull = 5
   psInsideFrame = 6
End Enum
Private Declare Function CreatePen Lib "gdi32" ( _
   ByVal nPenStyle As PenStyle, ByVal nWidth As Long, _
   ByVal crColor As Long) As Long

Private Declare Function CreateSolidBrush Lib "gdi32" ( _
   ByVal crColor As Long) As Long
Private Enum HatchBrushStyle
   HS_HORIZONTAL = 0              '  -----
   HS_VERTICAL = 1                '  |||||
   HS_FDIAGONAL = 2               '  \\\\\
   HS_BDIAGONAL = 3               '  /////
   HS_CROSS = 4                   '  +++++
   HS_DIAGCROSS = 5               '  xxxxx
End Enum
Private Declare Function CreateHatchBrush Lib "gdi32" ( _
   ByVal nIndex As HatchBrushStyle, ByVal crColor As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" ( _
   ByVal hBitmap As Long) As Long

Private Const NULL_BRUSH = 5
Private Declare Function GetStockObject Lib "gdi32" ( _
   ByVal nIndex As Long) As Long

Public Enum PolygonFillMode
   ALTERNATE = 1
   WINDING = 2
End Enum
Private Declare Function GetPolyFillMode Lib "gdi32" ( _
   ByVal hDC As Long) As PolygonFillMode
Private Declare Function SetPolyFillMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nPolyFillMode As PolygonFillMode) As PolygonFillMode
Private Declare Function Polygon Lib "gdi32" ( _
   ByVal hDC As Long, lpPoint As POINTAPI, ByVal nCount As Long) As BOOL

Private Declare Function SetBkColor Lib "gdi32" ( _
   ByVal hDC As Long, ByVal crColor As Long) As Long


Private Declare Function CreateEnhMetaFile Lib "gdi32" _
   Alias "CreateEnhMetaFileA" ( _
   ByVal hdcRef As Long, ByVal lpFileName As String, lpRect As RECT, _
   ByVal lpDescription As String) As Long
Private Declare Function CloseEnhMetaFile Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function GetEnhMetaFileBits Lib "gdi32" ( _
   ByVal hEMF As Long, ByVal cbBuffer As Long, lpbBuffer As Any) As Long

Private Enum MapMode
   MM_TEXT = 1
   MM_LOMETRIC = 2
   MM_HIMETRIC = 3
   MM_LOENGLISH = 4
   MM_HIENGLISH = 5
   MM_TWIPS = 6
   MM_ISOTROPIC = 7
   MM_ANISOTROPIC = 8 ' Map mode anisotropic
End Enum
Private Declare Function SetMapMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nMapMode As MapMode) As MapMode

Private Declare Function SetWindowExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, _
   lpSize As Any) As BOOL
Private Declare Function SetViewportExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, _
   ByVal nY As Long, lpSize As Any) As BOOL


Private Type BLENDFUNCTION
   BlendOp As Byte
   BlendFlags As Byte
   SourceConstantAlpha As Byte
   AlphaFormat As Byte
End Type
Private Type BLENDFUNCTIONBYVAL
   Value As Long
End Type
Private Const AC_SRC_OVER = &H0
'Alpha format flags
Private Const AC_SRC_ALPHA = &H1
'Private Const AC_SRC_NO_PREMULT_ALPHA = &H1
'Private Const AC_SRC_NO_ALPHA = &H2
'Private Const AC_DST_NO_PREMULT_ALPHA = &H10
'Private Const AC_DST_NO_ALPHA = &H20

Private Declare Function AlphaBlend Lib "msimg32" ( _
  ByVal hdcDest As Long, _
  ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, _
  ByVal nWidthDest As Long, ByVal nHeightDest As Long, _
  ByVal hdcSrc As Long, _
  ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, _
  ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, _
  ByVal lBlendFunction As Long) As BOOL


Private Enum CLIPFORMAT 'Predefined Clipboard Formats
   CF_TEXT = 1
   CF_BITMAP = 2
   CF_METAFILEPICT = 3
   CF_SYLK = 4
   CF_DIF = 5
   CF_TIFF = 6
   CF_OEMTEXT = 7
   CF_DIB = 8
   CF_PALETTE = 9
   CF_PENDATA = 10
   CF_RIFF = 11
   CF_WAVE = 12
   CF_UNICODETEXT = 13
   CF_ENHMETAFILE = 14
   CF_HDROP = 15
   CF_LOCALE = 16
   CF_MAX = 17
   CF_OWNERDISPLAY = &H80
   CF_DSPTEXT = &H81
   CF_DSPBITMAP = &H82
   CF_DSPMETAFILEPICT = &H83
   CF_DSPENHMETAFILE = &H8E
   '"Public" formats don't get GlobalFree()'d
   CF_PublicFIRST = &H200
   CF_PublicLAST = &H2FF
   '"GDIOBJ" formats do get DeleteObject()'d
   CF_GDIOBJFIRST = &H300
   CF_GDIOBJLAST = &H3FF
   'Registered formats
   CF_RegisteredFIRST = &HC000&
   CF_RegisteredLAST = &HFFFF&
End Enum


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

Private Declare Function CLSIDFromString Lib "ole32" ( _
   ByVal lpsz As Long, rguid As GUID) As Long
Private Const IIDSTR_IPictureDisp$ = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

Private Enum PICTYPE
   PICTYPE_UNINITIALIZED = -1
   PICTYPE_NONE = 0
   PICTYPE_BITMAP = 1
   PICTYPE_METAFILE = 2
   PICTYPE_ICON = 3
   PICTYPE_ENHMETAFILE = 4
End Enum

Private Type PICTDESCBMP
   cbSizeOfStruct As Long
   PictType As PICTYPE
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type

Private Type PICTDESCEMF
   cbSizeOfStruct As Long
   PictType As PICTYPE
   hEMF As Long
   Reserved1 As Long
   Reserved2 As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32" ( _
   pPictDesc As Any, riid As GUID, _
   ByVal fOwn As BOOL, ppvObj As IPictureDisp) As Long


#If Not PRAGMA_SAFE Then
Private Type SAFEARRAYBOUND
   cElements As Long
   lLbound As Long
End Type
Private Const FADF_STATIC As Integer = &H2       ' An array that is statically
                                                 ' allocated.
Private Const FADF_FIXEDSIZE As Integer = &H10   ' An array that may not be
                                                 ' resized or reallocated
Private Const FADF_HAVEVARTYPE As Integer = &H80 ' An array that has a VT type.
                                                 ' When set there will be a VT
                                                 ' tag at negative offset 4 in
                                                 ' the array descriptor that
                                                 ' specifies the element type.
Private Type SAFEARRAY2DHAVEVARTYPE
   vtElementType As VbVarType ' Element type
   cDims As Integer     ' Count of dimensions in this array.
   fFeatures As Integer ' Flags used by the SafeArray
   cbElements As Long   ' Size of an element of the array.
                        ' Does not include size of
                        ' pointed-to data.
   cLocks As Long       ' Number of times the array has been
                        ' locked without corresponding unlock.
   pvData As Long       ' Pointer to the data.
   ' One bound for each dimension.
   rgsabound1 As SAFEARRAYBOUND ' Dimension 1
   rgsabound2 As SAFEARRAYBOUND ' Dimension 2
End Type

'Вместо vba6 может понадобиться другая библиотека. См. Object Browser с
'включенной опцией Show Hidden Members, где находится VarPtr().
Private Declare Function VarPtrArray Lib "vba6" Alias "VarPtr" ( _
   Arr() As Any) As Long
#End If


Public Enum PictureDataFormat
   pdDIB = CF_DIB
   pdEMF = CF_ENHMETAFILE
End Enum

Private Type TQuadBytes
   bByte(0 To 3) As Byte
End Type
Private Type TLong
   lLong As Long
End Type


Dim m_nWidth As Long, m_nHeight As Long
Dim m_DS As DIBSECTION
Dim m_bmi As BITMAPINFO
Dim m_hbmMem As Long
Dim m_hbmOld As Long
Dim m_pBits As Long
Dim m_hdcSurface As Long

#If Not PRAGMA_SAFE Then
Dim m_crPixels() As Long
Dim m_sa2vtPixels As SAFEARRAY2DHAVEVARTYPE
#End If
'Перо
Dim m_nPenWidth As Long
Dim m_nPenStyle As PenStyle
Dim m_crPenColor As Long
Dim m_hpenCur As Long
Dim m_hpenOld As Long
'Кисть
Public Enum BrushStyle
   bsSolid
   bsNull
   bsPattern
   bsBDiagonal
   bsCross
   bsDiagCross
   bsFDiagonal
   bsHorizontal
   bsVertical
End Enum
Dim m_nBrushStyle As BrushStyle
Dim m_crBrushColor As Long
Dim m_crBrushBackColor As Long
Dim m_hbmBrushPattern As Long
Dim m_hbrCur As Long
Dim m_hbrOld As Long
Dim m_crOldBrushBkClr As Long
Dim m_crPenBackColor As Long
Dim m_crOldPenBkClr As Long


'Освобождение системных ресурсов
Private Sub Class_Terminate()
 If m_hbmMem Then
#If Not PRAGMA_SAFE Then
    CopyMemory ByVal VarPtrArray(m_crPixels), 0&, 4
#End If
    DeleteObject m_hbmMem: m_hbmMem = 0
 End If
 If m_hpenCur Then DeleteObject m_hpenCur: m_hpenCur = 0
 If m_hbrCur Then DeleteObject m_hbrCur: m_hbrCur = 0
End Sub

'Инициализация
Public Function Init(ByVal Width As Long, ByVal Height As Long) As Boolean
 Class_Terminate
 
 With m_bmi.bmiHeader
    .biSize = LenB(m_bmi.bmiHeader)
    .biPlanes = 1
    .biBitCount = 32
    .biWidth = Width
    .biHeight = Height
    .biCompression = BI_RGB 'BI_BITFIELDS
 End With
 m_hbmMem = CreateDIBSection(0, m_bmi, DIB_RGB_COLORS, m_pBits, 0, 0)

#If Not PRAGMA_SAFE Then
 If m_hbmMem = 0 Then Exit Function
 With m_sa2vtPixels
    .vtElementType = vbLong
    .cbElements = 4
    .cDims = 2
    .fFeatures = FADF_STATIC Or FADF_FIXEDSIZE Or FADF_HAVEVARTYPE
    .pvData = m_pBits
    .rgsabound1.cElements = Height
    .rgsabound2.cElements = Width
 End With
 CopyMemory ByVal VarPtrArray(m_crPixels), VarPtr(m_sa2vtPixels.cDims), 4
#End If

 Init = True
End Function


Public Property Get Width() As Long
 If m_hbmMem Then Width = m_bmi.bmiHeader.biWidth
End Property

Public Property Get Height() As Long
 If m_hbmMem Then Height = m_bmi.bmiHeader.biHeight
End Property


Public Function LoadPicture( _
   ByVal picSrc As IPictureDisp, _
   Optional ByVal xDst As Long, Optional ByVal yDst As Long) As Boolean
 Dim nDstWidth As Long, nDstHeight As Long
 Const TWIPS_PER_INCH = 72 * 20
 Const HIMETRIC_PER_INCH = 2540
 If picSrc Is Nothing Then Exit Function
 If picSrc.Handle = 0 Then Exit Function
 nDstWidth = picSrc.Width * TWIPS_PER_INCH / HIMETRIC_PER_INCH / _
             TwipsPerPixelX
 nDstHeight = picSrc.Height * TWIPS_PER_INCH / HIMETRIC_PER_INCH / _
              TwipsPerPixelY
 If m_hbmMem = 0 Then _
    If Not Init(nDstWidth, nDstHeight) Then Exit Function
 picSrc.Render CLng(SelectSurface), CLng(xDst), CLng(yDst), _
               CLng(nDstWidth), CLng(nDstHeight), _
               CLng(0&), CLng(picSrc.Height), _
               CLng(picSrc.Width), CLng(-picSrc.Height), ByVal 0&
 RestoreSurface
 LoadPicture = True
End Function


Public Property Get Picture( _
   Optional ByVal Format As PictureDataFormat = pdDIB, _
   Optional ByVal bAlpha As Byte = 255) As IPictureDisp
 If (Format = pdDIB) Or (Format = pdEMF) Then
    If m_hbmMem Then
       If Format = pdDIB Then
          Set Picture = DibPicture
       Else
          Set Picture = EmfPicture(bAlpha)
       End If
    End If
 Else
    Err.Raise 5
 End If
End Property

Private Property Get DibPicture() As IPictureDisp
 Dim IID_IPictureDisp As GUID
 Dim PictDesc As PICTDESCBMP
 With PictDesc
    .cbSizeOfStruct = Len(PictDesc)
    .PictType = PICTYPE_BITMAP
    .hBmp = m_hbmMem
    .hPal = 0
 End With
 CLSIDFromString StrPtr(IIDSTR_IPictureDisp), IID_IPictureDisp
 OleCreatePictureIndirect PictDesc, IID_IPictureDisp, FALSE_BOOL, DibPicture
End Property

Private Property Get EmfPicture( _
   Optional ByVal bAlpha As Byte = 255) As IPictureDisp
 Dim hicRef As Long
 Dim iWidthMM As Long
 Dim iHeightMM As Long
 Dim iWidthPels As Long
 Dim iHeightPels As Long
 Dim iDPIX As Long
 Dim iDPIY As Long
 Dim rc As RECT
 Dim hdcMeta As Long
 Dim iWEX As Long, iWEY As Long
 Dim iVEX As Long, iVEY As Long
 Dim iGCD As Long
 Dim hdcMem As Long
 Dim hbmpOld As Long
 Dim hEMF As Long
 Dim bfBlend As BLENDFUNCTION
 Dim bfvBlend As BLENDFUNCTIONBYVAL
 Dim IID_IPictureDisp As GUID
 Dim PictDesc As PICTDESCEMF
 
 hicRef = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
 iWidthMM = GetDeviceCaps(hicRef, HORZSIZE)
 iHeightMM = GetDeviceCaps(hicRef, VERTSIZE)
 iWidthPels = GetDeviceCaps(hicRef, HORZRES)
 iHeightPels = GetDeviceCaps(hicRef, VERTRES)
 iDPIX = GetDeviceCaps(hicRef, LOGPIXELSX)
 iDPIY = GetDeviceCaps(hicRef, LOGPIXELSY)
 
 'Размеры в сотых долях миллиметра
 rc.Right = Int(m_bmi.bmiHeader.biWidth * 2540 / iDPIX + 0.5)
 rc.Bottom = Int(m_bmi.bmiHeader.biHeight * 2540 / iDPIY + 0.5)
 
 'Создаём "усовершенствованный" метафайл в памяти и на диске, если дано имя
 hdcMeta = CreateEnhMetaFile(hicRef, vbNullString, rc, vbNullString)
 
 iWEX = m_bmi.bmiHeader.biWidth * iWidthMM * iDPIX * 10
 iWEY = m_bmi.bmiHeader.biHeight * iHeightMM * iDPIY * 10
 iVEX = m_bmi.bmiHeader.biWidth * iWidthPels * 254
 iVEY = m_bmi.bmiHeader.biHeight * iHeightPels * 254
 iGCD = GCD(GCD(GCD(iWEX, iWEY), iVEX), iVEY)
 SetMapMode hdcMeta, MM_ANISOTROPIC
 SetWindowExtEx hdcMeta, iWEX \ iGCD, iWEY \ iGCD, ByVal 0&
 SetViewportExtEx hdcMeta, iVEX \ iGCD, iVEY \ iGCD, ByVal 0&
 
 hdcMem = CreateCompatibleDC(hicRef)
 DeleteDC hicRef: hicRef = 0
 hbmpOld = SelectObject(hdcMem, m_hbmMem)

 bfBlend.BlendOp = AC_SRC_OVER
 bfBlend.BlendFlags = 0
 bfBlend.SourceConstantAlpha = bAlpha
 bfBlend.AlphaFormat = 0 'AC_SRC_ALPHA
 LSet bfvBlend = bfBlend
 AlphaBlend hdcMeta, 0, 0, m_bmi.bmiHeader.biWidth, m_bmi.bmiHeader.biHeight, _
            hdcMem, 0, 0, m_bmi.bmiHeader.biWidth, m_bmi.bmiHeader.biHeight, _
            bfvBlend.Value

 SelectObject hdcMem, hbmpOld: hbmpOld = 0
 DeleteDC hdcMem: hdcMem = 0
    
 hEMF = CloseEnhMetaFile(hdcMeta): hdcMeta = 0
 
 With PictDesc
    .cbSizeOfStruct = Len(PictDesc)
    .PictType = PICTYPE_ENHMETAFILE
    .hEMF = hEMF
 End With
 CLSIDFromString StrPtr(IIDSTR_IPictureDisp), IID_IPictureDisp
 OleCreatePictureIndirect PictDesc, IID_IPictureDisp, TRUE_BOOL, _
                          EmfPicture
 hEMF = 0
End Property

Public Property Get PictureData( _
   Optional ByVal Format As PictureDataFormat = pdDIB, _
   Optional ByVal bAlphaEMF As Byte = 255) As Byte()
 Dim picSrc As IPictureDisp
 Dim cbSize As Long, cbCopied As Long
 Dim bData() As Byte
 If (Format = pdDIB) Or (Format = pdEMF) Then
    If m_hbmMem = 0 Then Exit Property
    If Format = pdDIB Then
       With m_bmi.bmiHeader
          cbSize = .biSizeImage
          If cbSize = 0 Then cbSize = .biWidth * .biHeight * 4
          ReDim bData(0 To .biSize + cbSize - 1) As Byte
          CopyMemory bData(0), m_bmi.bmiHeader, .biSize
          CopyMemory bData(.biSize), ByVal m_pBits, cbSize
       End With
    Else
       Set picSrc = EmfPicture(bAlphaEMF)
       If picSrc Is Nothing Then Exit Property
       cbSize = GetEnhMetaFileBits(picSrc.Handle, 0, ByVal 0&)
       ReDim bData(0 To cbSize + 7) As Byte
       PutPicDataLong bData, cbCopied, CF_ENHMETAFILE
       PutPicDataLong bData, cbCopied, picSrc.Handle
       cbCopied = GetEnhMetaFileBits(picSrc.Handle, cbSize, bData(cbCopied))
    End If
    PictureData = bData
 Else
    Err.Raise 5
 End If
End Property

Private Function GCD(ByVal a As Long, ByVal b As Long) As Long
 Do While (a <> 0) And (b <> 0)
    If a >= b Then a = a Mod b Else b = b Mod a
 Loop
 GCD = a + b
End Function

Private Sub PutPicDataLong(bData() As Byte, nPos As Long, ByVal lValue As Long)
 Dim L As TLong
 Dim QB As TQuadBytes
 L.lLong = lValue
 LSet QB = L
 bData(nPos + 0) = QB.bByte(0)
 bData(nPos + 1) = QB.bByte(1)
 bData(nPos + 2) = QB.bByte(2)
 bData(nPos + 3) = QB.bByte(3)
 nPos = nPos + 4
End Sub


'Перо
Public Property Get PenWidth() As Long
 PenWidth = m_nPenWidth
End Property

Public Property Let PenWidth(ByVal Width As Long)
 m_nPenWidth = Width
End Property

Public Property Get PenStyle() As PenStyle
 PenStyle = m_nPenStyle
End Property

Public Property Let PenStyle(ByVal Style As PenStyle)
 m_nPenStyle = Style
End Property

Public Property Get PenColor() As Long
 PenColor = m_crPenColor
End Property

Public Property Let PenColor(ByVal Color As Long)
 m_crPenColor = Color
End Property

Public Property Get PenBackColor() As Long
 PenColor = m_crPenBackColor
End Property

Public Property Let PenBackColor(ByVal Color As Long)
 m_crPenBackColor = Color
End Property

Private Function SelectPen(ByVal hDC As Long) As Long
 m_hpenCur = CreatePen(m_nPenStyle, m_nPenWidth, m_crPenColor)
 m_hpenOld = SelectObject(hDC, m_hpenCur)
 SelectPen = m_hpenOld
 m_crOldPenBkClr = SetBkColor(hDC, m_crPenBackColor)
End Function

Private Function RestorePen(ByVal hDC As Long) As Long
 RestorePen = SelectObject(hDC, m_hpenOld): m_hpenOld = 0
 DeleteObject m_hpenCur: m_hpenCur = 0
 SetBkColor hDC, m_crOldPenBkClr
End Function


'Кисть
Public Property Get BrushStyle() As BrushStyle
 BrushStyle = m_nBrushStyle
End Property

Public Property Let BrushStyle(ByVal Style As BrushStyle)
 m_nBrushStyle = Style
End Property

Public Property Get BrushColor() As Long
 BrushColor = m_crBrushColor
End Property

Public Property Let BrushColor(ByVal Color As Long)
 m_crBrushColor = Color
End Property

Public Property Get BrushBackColor() As Long
 BrushBackColor = m_crBrushBackColor
End Property

Public Property Let BrushBackColor(ByVal Color As Long)
 m_crBrushBackColor = Color
End Property

Public Property Get BrushPattern() As Long
 If m_nBrushStyle = bsPattern Then BrushPattern = m_hbmBrushPattern
End Property

Public Property Let BrushPattern(ByVal hbmPattern As Long)
 If hbmPattern Then
    m_nBrushStyle = bsPattern
 ElseIf m_nBrushStyle = bsPattern Then
    m_nBrushStyle = bsSolid
 End If
 m_hbmBrushPattern = hbmPattern
End Property

Private Function SelectBrush(ByVal hDC As Long) As Long
 Select Case m_nBrushStyle
 Case bsSolid:
    m_hbrCur = CreateSolidBrush(m_crBrushColor)
    m_hbrOld = SelectObject(hDC, m_hbrCur)
 Case bsNull:
    m_hbrCur = GetStockObject(NULL_BRUSH)
    m_hbrOld = SelectObject(hDC, m_hbrCur)
 Case bsPattern:
    m_hbrCur = CreatePatternBrush(m_hbmBrushPattern)
    m_hbrOld = SelectObject(hDC, m_hbrCur)
 Case bsBDiagonal:
    m_hbrCur = CreateHatchBrush(HS_BDIAGONAL, m_crBrushColor)
    m_hbrOld = SelectObject(hDC, m_hbrCur)
    m_crOldBrushBkClr = SetBkColor(hDC, m_crBrushBackColor)
 Case bsCross:
    m_hbrCur = CreateHatchBrush(HS_CROSS, m_crBrushColor)
    m_hbrOld = SelectObject(hDC, m_hbrCur)
    m_crOldBrushBkClr = SetBkColor(hDC, m_crBrushBackColor)
 Case bsDiagCross:
    m_hbrCur = CreateHatchBrush(HS_DIAGCROSS, m_crBrushColor)
    m_hbrOld = SelectObject(hDC, m_hbrCur)
    m_crOldBrushBkClr = SetBkColor(hDC, m_crBrushBackColor)
 Case bsFDiagonal:
    m_hbrCur = CreateHatchBrush(HS_FDIAGONAL, m_crBrushColor)
    m_hbrOld = SelectObject(hDC, m_hbrCur)
    m_crOldBrushBkClr = SetBkColor(hDC, m_crBrushBackColor)
 Case bsHorizontal:
    m_hbrCur = CreateHatchBrush(HS_HORIZONTAL, m_crBrushColor)
    m_hbrOld = SelectObject(hDC, m_hbrCur)
    m_crOldBrushBkClr = SetBkColor(hDC, m_crBrushBackColor)
 Case bsVertical:
    m_hbrCur = CreateHatchBrush(HS_VERTICAL, m_crBrushColor)
    m_hbrOld = SelectObject(hDC, m_hbrCur)
    m_crOldBrushBkClr = SetBkColor(hDC, m_crBrushBackColor)
 End Select
End Function

Private Function RestoreBrush(ByVal hDC As Long) As Long
 Select Case m_nBrushStyle
 Case bsBDiagonal, bsCross, bsDiagCross, bsFDiagonal, bsHorizontal, bsVertical:
    SetBkColor hDC, m_crOldBrushBkClr
 End Select
 RestoreBrush = SelectObject(hDC, m_hbrOld): m_hbrOld = 0
 If m_nBrushStyle <> bsNull Then
    DeleteObject m_hbrCur: m_hbrCur = 0
 End If
End Function


'Примитивы отрисовки
Private Function SelectSurface() As Long
 m_hdcSurface = CreateCompatibleDC(0)
 m_hbmOld = SelectObject(m_hdcSurface, m_hbmMem)
 SelectSurface = m_hdcSurface
End Function

Private Function RestoreSurface() As BOOL
 SelectObject m_hdcSurface, m_hbmOld: m_hbmOld = 0
 RestoreSurface = DeleteDC(m_hdcSurface): m_hdcSurface = 0
End Function


'Точка
Public Sub DrawPixel(ByVal X As Long, ByVal Y As Long, ByVal Color As Long)
 SetPixel SelectSurface, X, Y, Color
 RestoreSurface
End Sub

Private Function SwapRB(ByVal Color As Long) As Long
 SwapRB = ((Color And &HFF&) * &H10000) Or (Color And &HFF00&) Or _
          ((Color And &HFF0000) \ &H10000)
End Function

Public Property Let Pixel(ByVal X As Long, ByVal Y As Long, ByVal Color As Long)
#If PRAGMA_SAFE Then
 If (X >= 0) And (X < m_bmi.bmiHeader.biWidth) And _
    (Y >= 0) And (Y < m_bmi.bmiHeader.biHeight) Then
    CopyMemory ByVal m_pBits + (m_bmi.bmiHeader.biWidth * _
               (m_bmi.bmiHeader.biHeight - 1 - Y) + X) * 4, _
               SwapRB(Color), 4
    'PutMem4 ByVal m_pBits + (m_bmi.bmiHeader.biWidth * _
            (m_bmi.bmiHeader.biHeight - 1 - Y) + X) * 4, SwapRB(Color)
 Else
    'Err.Raise 9
 End If
#Else
 m_crPixels(X, m_bmi.bmiHeader.biHeight - 1 - Y) = SwapRB(Color)
#End If
End Property

Public Property Get Pixel(ByVal X As Long, ByVal Y As Long) As Long
#If PRAGMA_SAFE Then
 Dim Color As Long
 If (X >= 0) And (X < m_bmi.bmiHeader.biWidth) And _
    (Y >= 0) And (Y < m_bmi.bmiHeader.biHeight) Then
    CopyMemory Color, _
               ByVal m_pBits + (m_bmi.bmiHeader.biWidth * _
               (m_bmi.bmiHeader.biHeight - 1 - Y) + X) * 4, _
               4
    'GetMem4 ByVal m_pBits + (m_bmi.bmiHeader.biWidth * _
            (m_bmi.bmiHeader.biHeight - 1 - Y) + X) * 4, _
            Color
    Pixel = SwapRB(Color)
 Else
    Err.Raise 9
 End If
#Else
 Pixel = SwapRB(m_crPixels(X, m_bmi.bmiHeader.biHeight - 1 - Y))
#End If
End Property

'Линия
Public Sub DrawLine(ByVal X0 As Long, ByVal Y0 As Long, _
                    ByVal X1 As Long, ByVal Y1 As Long)
 Dim hDC As Long
 hDC = SelectSurface()
 SelectPen hDC
 
 MoveToEx hDC, X0, Y0, ByVal 0&
 LineTo hDC, X1, Y1
 
 RestorePen hDC
 RestoreSurface
End Sub

'Прямоугольник
Public Sub DrawRectangle(ByVal X0 As Long, ByVal Y0 As Long, _
                         ByVal X1 As Long, ByVal Y1 As Long)
 Dim hDC As Long
 hDC = SelectSurface()
 SelectPen hDC
 SelectBrush hDC
 
 Rectangle hDC, X0, Y0, X1, Y1
 
 RestoreBrush hDC
 RestorePen hDC
 RestoreSurface
End Sub

'Эллипс
Public Sub DrawEllipse(ByVal X0 As Long, ByVal Y0 As Long, _
                       ByVal X1 As Long, ByVal Y1 As Long)
 Dim hDC As Long
 hDC = SelectSurface()
 SelectPen hDC
 SelectBrush hDC
 
 Ellipse hDC, X0, Y0, X1, Y1
 
 RestoreBrush hDC
 RestorePen hDC
 RestoreSurface
End Sub

'Ломаная
Friend Sub DrawPolyline(Points() As POINTAPI, Optional ByVal Count As Long)
 Dim hDC As Long
 hDC = SelectSurface()
 SelectPen hDC

 If Count = 0 Then Count = UBound(Points) - LBound(Points) + 1
 Polyline hDC, Points(LBound(Points)), Count
 
 RestorePen hDC
 RestoreSurface
End Sub

'Многоугольник
Friend Sub DrawPolygon(Points() As POINTAPI, Optional ByVal Count As Long, _
                       Optional FillMode As PolygonFillMode)
 Dim hDC As Long
 Dim nFillMode As PolygonFillMode
 hDC = SelectSurface()
 SelectPen hDC
 SelectBrush hDC
 If FillMode Then
    nFillMode = GetPolyFillMode(hDC)
    SetPolyFillMode hDC, FillMode
 End If
 
 If Count = 0 Then Count = UBound(Points) - LBound(Points) + 1
 Polygon hDC, Points(LBound(Points)), Count
 
 If FillMode Then SetPolyFillMode hDC, nFillMode
 RestoreBrush hDC
 RestorePen hDC
 RestoreSurface
End Sub


Public Function CaptureWindow( _
   ByVal hWnd As Long, _
   Optional ByVal Left As Long, Optional ByVal Top As Long, _
   Optional ByVal Width As Long, Optional ByVal Height As Long, _
   Optional ByVal NonClient As Boolean) As IPictureDisp
 Dim rcSrc As RECT
 Dim hdcSrc As Long
 Dim hdcDst As Long
 Dim hbmDstOld As Long
 Dim bRes As BOOL
 
 Do
    If NonClient Then
       If GetWindowRect(hWnd, rcSrc) = FALSE_BOOL Then Exit Do
       hdcSrc = GetWindowDC(hWnd)
    Else
       If GetClientRect(hWnd, rcSrc) = FALSE_BOOL Then Exit Do
       hdcSrc = GetDC(hWnd)
    End If
    If hdcSrc = 0 Then Exit Do
    
    If (Left Or Top Or Width Or Height) = 0 Then
       Width = rcSrc.Right - rcSrc.Left
       Height = rcSrc.Bottom - rcSrc.Top
    End If
    
    If Init(Width, Height) Then
       hdcDst = CreateCompatibleDC(hdcSrc)
       If hdcDst Then
          hbmDstOld = SelectObject(hdcDst, m_hbmMem)
          
          bRes = BitBlt(hdcDst, 0, 0, Width, Height, hdcSrc, Left, Top, SRCCOPY)
       
          SelectObject hdcDst, hbmDstOld: hbmDstOld = 0
          DeleteDC hdcDst: hdcDst = 0
       End If
    End If
    
    ReleaseDC hWnd, hdcSrc: hdcSrc = 0
    
    If bRes = FALSE_BOOL Then Exit Do
    
    'Штатный выход
    Set CaptureWindow = Picture
    Exit Function
 Loop While False
 
 'Выход при ошибке
 Class_Terminate
End Function

Public Function CaptureScreen( _
   Optional ByVal Left As Long, Optional ByVal Top As Long, _
   Optional ByVal Width As Long, Optional ByVal Height As Long) As IPictureDisp
 Set CaptureScreen = CaptureWindow(GetDesktopWindow, Left, Top, Width, Height)
End Function