Attribute VB_Name = "MdlFuntions"
Option Explicit
Private Declare Function GdipGetPropertyItem Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mPropId As Long, ByVal mPropSize As Long, ByRef mBuffer As Any) As Long
Private Declare Function GdipGetPropertyItemSize Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mPropId As Long, ByRef msize As Long) As Long
Private Declare Function GdipImageRotateFlip Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mRfType As RotateFlipType) As Long
Private Declare Function GdipLoadImageFromFile Lib "GdiPlus.dll" (ByVal mFilename As Long, ByRef mImage As Long) As Long
Private Declare Function GdipGetImageThumbnail Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mThumbWidth As Long, ByVal mThumbHeight As Long, ByRef mThumbImage As Long, ByRef mcallback As Variant, ByRef mcallbackData As Variant) As Long
Public Declare Function GdipDrawImageRectI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mImage As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Public Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal mImage As Long) As Long
Public Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, hGraphics As Long) As Long
Public Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal hGraphics As Long) As Long
Public Declare Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mHeight As Long) As Long
Public Declare Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mWidth As Long) As Long
Public Declare Function GdipSetSmoothingMode Lib "gdiplus" (ByVal graphics As Long, ByVal SmoothingMd As Long) As Long
Private Declare Function GdipCreatePen1 Lib "GdiPlus.dll" (ByVal mColor As Long, ByVal mWidth As Single, ByVal mUnit As Long, ByRef mPen As Long) As Long
Private Declare Function GdipCreatePath Lib "GdiPlus.dll" (ByRef mBrushMode As Long, ByRef mPath As Long) As Long
Private Declare Function GdipDeletePath Lib "GdiPlus.dll" (ByVal mPath As Long) As Long
Private Declare Function GdipDrawPath Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal mPath As Long) As Long
Private Declare Function GdipFillPath Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mPath As Long) As Long
Private Declare Function GdipAddPathArcI Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long, ByVal mStartAngle As Single, ByVal mSweepAngle As Single) As Long
Private Declare Function GdipDeletePen Lib "GdiPlus.dll" (ByVal mPen As Long) As Long
Private Declare Function GdipAddPathLineI Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mX1 As Long, ByVal mY1 As Long, ByVal mX2 As Long, ByVal mY2 As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal argb As Long, ByRef Brush As Long) As Long
Private Declare Function GdipClosePathFigure Lib "GdiPlus.dll" (ByVal mPath As Long) As Long
Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal Brush As Long) As Long
Private Declare Function GdipSetClipPath Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mPath As Long, ByVal mCombineMode As Long) As Long
Private Declare Function GdipResetClip Lib "GdiPlus.dll" (ByVal mGraphics As Long) As Long
Private Declare Function GdipCreateTexture Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mWrapMode As Long, ByRef mTexture As Long) As Long
Private Declare Function GdipCreateTexture2I Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mWrapMode As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long, ByRef mTexture As Long) As Long
Private Declare Function GdipTranslateWorldTransform Lib "gdiplus" (ByVal graphics As Long, ByVal dx As Single, ByVal dy As Single, ByVal Order As Long) As Long
Private Declare Function GdipTranslateTextureTransform Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mDx As Single, ByVal mDy As Single, ByVal mOrder As Long) As Long
Private Declare Function GdipCreateTextureIAI Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mImageAttributes As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long, ByRef mTexture As Long) As Long
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As IUnknown, ByRef Image As Long) As Long
Private Declare Function GdipAddPathCurveI Lib "GdiPlus.dll" (ByVal mPath As Long, ByRef mPoints As POINTL, ByVal mCount As Long) As Long
Private Declare Function GdipAddPathClosedCurveI Lib "GdiPlus.dll" (ByVal mPath As Long, ByRef mPoints As POINTL, ByVal mCount As Long) As Long
Private Declare Function GdipSetPathGradientCenterColor Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mColors As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "GdiPlus.dll" (ByVal mBrush As Long, ByRef mColor As Long, ByRef mCount As Long) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "GdiPlus.dll" (ByVal mPath As Long, ByRef mPolyGradient As Long) As Long

Private Declare Function DrawTextW Lib "user32.dll" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, ByRef lpRect As Rect, ByVal wFormat As Long) As Long
Private Declare Function PathIsURL Lib "shlwapi.dll" Alias "PathIsURLA" (ByVal pszPath As String) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long
Private Declare Sub CreateStreamOnHGlobal Lib "Ole32.dll" (ByRef hGlobal As Any, ByVal fDeleteOnRelease As Long, ByRef ppstm As Any)
Private Declare Function CryptStringToBinaryA Lib "crypt32.dll" (ByVal pszString As String, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByVal pcbBinary As Long, ByVal pdwSkip As Long, ByVal pdwFlags As Long) As Long
Private Declare Sub CopyMemory Lib "Kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Type POINTL
    X As Long
    Y As Long
End Type

Private Enum RotateFlipType
    RotateNoneFlipNone = &H0
    Rotate90FlipNone = &H1
    Rotate180FlipNone = &H2
    Rotate270FlipNone = &H3
    RotateNoneFlipX = &H4
    Rotate90FlipX = &H5
    Rotate180FlipX = &H6
    Rotate270FlipX = &H7
    RotateNoneFlipY = &H6
    Rotate90FlipY = &H7
    Rotate180FlipY = &H4
    Rotate270FlipY = &H5
    RotateNoneFlipXY = &H2
    Rotate90FlipXY = &H3
    Rotate180FlipXY = &H0
    Rotate270FlipXY = &H1
End Enum

Const PropertyTagOrientation = &H112
'
'Public Enum eDrawTextConst
'    DT_VCENTER = &H4
'    DT_BOTTOM = &H8
'    DT_CALCRECT = &H400
'    DT_CENTER = &H1
'    DT_EDITCONTROL = &H2000
'    DT_END_ELLIPSIS = &H8000
'    DT_EXPANDTABS = &H40
'    DT_EXTERNALLEADING = &H200
'    DT_HIDEPREFIX = &H100000
'    DT_INTERNAL = &H1000
'    DT_LEFT = &H0
'    DT_MODIFYSTRING = &H10000
'    DT_NOCLIP = &H100
'    DT_NOFULLWIDTHCHARBREAK = &H80000
'    DT_NOPREFIX = &H800
'    DT_PATH_ELLIPSIS = &H4000
'    DT_PREFIXONLY = &H200000
'    DT_RIGHT = &H2
'    DT_RTLREADING = &H20000
'    DT_SINGLELINE = &H20
'    DT_TABSTOP = &H80
'    DT_TOP = &H0
'    DT_WORDBREAK = &H10
'    DT_WORD_ELLIPSIS = &H40000
'End Enum


Private Type Rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
'
'Public Sub DrawText(ByVal hdc As Long, ByVal Text As String, ByVal Left As Long, ByVal Top As Long, Width As Long, Height As Long, dwFlags As eDrawTextConst)
'    Dim R As Rect
'
'    If ((dwFlags And DT_WORDBREAK) = DT_WORDBREAK) And ((dwFlags And DT_WORD_ELLIPSIS) = DT_WORD_ELLIPSIS) Then
'        Text = EllipsifyEnd(hdc, Text, Width, Height, dwFlags)
'    End If
'
'    R.Left = Left
'    R.Top = Top
'    R.Right = Left + Width
'    R.Bottom = Top + Height
'    DrawTextW hdc, StrPtr(Text), -1, R, dwFlags
'    Width = R.Right - R.Left
'    Height = R.Bottom - R.Top
'End Sub
'
'Private Function EllipsifyEnd(ByVal lhDC As Long, _
'   ByVal sText As String, _
'   ByVal Width As Long, _
'   ByVal Height As Long, _
'   ByVal dwFlags As Long) As String
'
'   Dim rct              As Rect
'   Dim len_str          As Long
'   Dim i                As Long
'   Dim sTemp            As String
'   Const cEllipsis      As String = "..."
'
'   If LenB(sText) = 0 Then
'      Exit Function
'   End If
'
'   rct.Right = Width
'
'   DrawTextW lhDC, StrPtr(sText), -1, rct, dwFlags Or DT_CALCRECT
'   If rct.Bottom <= Height Then
'      'String fits to just return string
'      EllipsifyEnd = sText
'      Exit Function
'   End If
'
'   'Remove
'   len_str = Len(sText) - 1
'
'   For i = len_str To 1 Step -1
'      sTemp = Left$(sText, i) & cEllipsis
'      rct.Right = Width
'      rct.Bottom = 0
'      DrawTextW lhDC, StrPtr(sTemp), -1, rct, dwFlags Or DT_CALCRECT
'      If rct.Bottom <= Height Then
'         'String portion + Ellipsis fits.
'         EllipsifyEnd = sTemp
'         Exit Function
'      End If
'   Next
'   'Nothing fits so return ellipsis only.
'   EllipsifyEnd = cEllipsis
'
'End Function



Public Function GetImageThumbnail(ByVal SrcImg As String, Optional BoxSize As Long = 200)
    Dim hImage As Long, hThumb As Long
    Dim nSize As Long, tProp() As Long
    Dim W As Long, H As Long
    Dim Width As Long, Height As Long
    Dim myScale As Long
    Dim DataArr() As Byte
    
    Select Case VarType(SrcImg)
        Case vbString
            If PathIsURL(SrcImg) Then
            
                If Left$(LCase(SrcImg), 5) = "data:" Then
                    Base64Decode Split(SrcImg, ",")(1), DataArr
                    Call LoadImageFromArray(DataArr, hImage)
                Else
                    Dim oXMLHTTP As Object
                    Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")
                    
                    oXMLHTTP.Open "GET", SrcImg, False
                    oXMLHTTP.send
'                    While oXMLHTTP.ReadyState <> 4
'                        DoEvents
'                    Wend
                    If oXMLHTTP.Status = 200 Then
                        DataArr() = oXMLHTTP.responseBody
                        Call LoadImageFromArray(DataArr, hImage)
                    End If
                End If
            Else
                Call GdipLoadImageFromFile(ByVal StrPtr(SrcImg), hImage)
            End If
        Case (vbArray Or vbByte)
            DataArr() = SrcImg
            Call LoadImageFromArray(DataArr, hImage)
    End Select

    If hImage = 0 Then Exit Function
    
    GdipGetImageWidth hImage, W
    GdipGetImageHeight hImage, H
    
    myScale = IIf(W >= H, W, H)
    Width = W * (BoxSize / myScale)
    Height = H * (BoxSize / myScale)

    GdipGetImageThumbnail hImage, Width, Height, hThumb, 0&, 0&
    GetImageThumbnail = hThumb
    If hThumb = 0 Then
        GetImageThumbnail = hImage
        Exit Function
    End If
    Call GdipGetPropertyItemSize(hImage, PropertyTagOrientation, nSize)
    
    If nSize > 0 Then
        ReDim tProp((nSize / 4) - 1)
        Call GdipGetPropertyItem(hImage, PropertyTagOrientation, nSize, tProp(0))
        GdipDisposeImage hImage
    Else
        GdipDisposeImage hImage
        Exit Function
    End If

    If (tProp(4) >= 1 And tProp(4) <= 8) Then
        Select Case (tProp(4))
            Case 2: GdipImageRotateFlip hThumb, RotateNoneFlipX
            Case 3: GdipImageRotateFlip hThumb, Rotate180FlipNone
            Case 4: GdipImageRotateFlip hThumb, Rotate180FlipX
            Case 5: GdipImageRotateFlip hThumb, Rotate90FlipX
            Case 6: GdipImageRotateFlip hThumb, Rotate90FlipNone
            Case 7: GdipImageRotateFlip hThumb, Rotate270FlipX
            Case 8: GdipImageRotateFlip hThumb, Rotate270FlipNone
        End Select
    End If
End Function


Private Function LoadImageFromArray(ByRef bvData() As Byte, ByRef hImage As Long) As Boolean
    On Local Error GoTo LoadImageFromArray_Error
    Dim IStream     As IUnknown
    If Not IsArrayDim(VarPtrArray(bvData)) Then Exit Function
    
    Call CreateStreamOnHGlobal(bvData(0), 0&, IStream)
    If Not IStream Is Nothing Then
        If GdipLoadImageFromStream(IStream, hImage) = 0 Then
            LoadImageFromArray = True
        End If
    End If
    Set IStream = Nothing
    
LoadImageFromArray_Error:
End Function

Private Function Base64Decode(ByVal sIn As String, ByRef bvOut() As Byte) As Boolean 'By Cocus
    Dim lLenOut As Long
    Const CRYPT_STRING_BASE64 = &H1
    Call CryptStringToBinaryA(sIn, Len(sIn), CRYPT_STRING_BASE64, 0, VarPtr(lLenOut), 0, 0)
    If lLenOut = 0 Then Exit Function
    ReDim bvOut(lLenOut - 1)
    Call CryptStringToBinaryA(sIn, Len(sIn), CRYPT_STRING_BASE64, VarPtr(bvOut(0)), VarPtr(lLenOut), 0, 0)
    Base64Decode = True
End Function

Private Function IsArrayDim(ByVal lpArray As Long) As Boolean
    Dim lAddress As Long
    Call CopyMemory(lAddress, ByVal lpArray, &H4)
    IsArrayDim = Not (lAddress = 0)
End Function


Private Function CreateRoundPath(ByVal Left As Long, ByVal Top As Long, _
                            ByVal Width As Long, ByVal Height As Long, _
                            R1 As Long, R2 As Long, R3 As Long, R4 As Long)
    Dim mPath As Long
    If GdipCreatePath(&H0, mPath) = 0 Then
        GdipAddPathArcI mPath, Left, Top, R1, R1, 180, 90
        GdipAddPathLineI mPath, Left + R1, Top, Left + Width - R2 - R1, Top
        GdipAddPathArcI mPath, Left + Width - R1, Top, R2, R2, 270, 90
        GdipAddPathLineI mPath, Left + Width, Top + R2, Left + Width, Top + Height - R2 - R3
        GdipAddPathArcI mPath, Left + Width - R3, Top + Height - R3, R3, R3, 0, 90
        GdipAddPathLineI mPath, Left + Width - R3, Top + Height, Left + R4, Top + Height
        GdipAddPathArcI mPath, Left, Top + Height - R4, R4, R4, 90, 90
        GdipClosePathFigure mPath

        CreateRoundPath = mPath
    End If
End Function


Public Function Fillcaca(hGraphics As Long, ByVal Left As Long, ByVal Top As Long, _
                            ByVal Width As Long, ByVal Height As Long)
    Dim mPath As Long, hBrush As Long
    Dim PT(2) As POINTL
    
    If GdipCreatePath(&H0, mPath) = 0 Then
        GdipAddPathLineI mPath, Left, Top, Left, Top + Height
        GdipAddPathLineI mPath, Left, Top + Height, Left + Width, Top + Height
        GdipAddPathLineI mPath, Left + Width, Top + Height, Left + Width, Top
        
        
        PT(0).X = Left + Width: PT(0).Y = Top
        PT(1).X = Left + Width / 2: PT(1).Y = Top + Height / 2
        PT(2).X = Left: PT(2).Y = Top
        GdipAddPathCurveI mPath, PT(0), 3
        
        GdipClosePathFigure mPath
        
        GdipCreatePathGradientFromPath mPath, hBrush
        
        GdipSetPathGradientCenterColor hBrush, &HFFFFFF                 'Asigna un color central a la brocha
        GdipSetPathGradientSurroundColorsWithCount hBrush, &HFFFFFFFF, 1
        
        'GdipCreateSolidFill &HFF0000FF, hBrush
        GdipFillPath hGraphics, hBrush, mPath
        GdipDeleteBrush hBrush
        GdipDeletePath mPath
        
    End If
End Function




Public Sub RoundRectPlus(ByVal hdc As Long, ByVal Left As Long, ByVal Top As Long, _
                       ByVal Width As Long, ByVal Height As Long, ByVal BackColor As Long, _
                       ByVal BorderColor As Long, ByVal BorderWidth As Long, R1 As Long, R2 As Long, R3 As Long, R4 As Long)
    Dim hPen As Long, hBrush As Long, mPath As Long, hGraphics As Long

    If BackColor <> 0 Then GdipCreateSolidFill BackColor, hBrush
    If BorderColor <> 0 Then GdipCreatePen1 BorderColor, BorderWidth, &H2, hPen

    GdipCreateFromHDC hdc, hGraphics
    GdipSetSmoothingMode hGraphics, &H4
    
    mPath = CreateRoundPath(Left, Top, Width, Height, R1, R2, R3, R4)
    If mPath Then
        If hBrush Then GdipFillPath hGraphics, hBrush, mPath
        If hPen Then GdipDrawPath hGraphics, hPen, mPath
        Call GdipDeletePath(mPath)
    End If

    If hBrush Then Call GdipDeleteBrush(hBrush)
    If hPen Then Call GdipDeletePen(hPen)
    GdipDeleteGraphics hGraphics
End Sub

Public Sub DrawImage(ByVal hdc As Long, ByVal hImage As Long, _
                            ByVal Left As Long, ByVal Top As Long, _
                            ByVal Width As Long, ByVal Height As Long, _
                            R1 As Long, R2 As Long, R3 As Long, R4 As Long)
                       
  
    Dim IMW As Long, IMH As Long, W As Long, H As Long
    Dim F As Single
    Dim hBrush As Long, hThumb As Long, mPath As Long
    Dim hGraphics As Long
    
    GdipCreateFromHDC hdc, hGraphics
    GdipSetSmoothingMode hGraphics, &H4
    
    GdipGetImageWidth hImage, IMW
    GdipGetImageHeight hImage, IMH
    
    F = IIf(IMH > IMW, Width / IMW, Height / IMW)
    W = IMW * F
    H = IMH * F
    If Height > Width Then
        If H < Height Then F = (Height / IMH)
    Else
        If W < Width Then F = (Width / IMH)
    End If
    W = IMW * F
    H = IMH * F
    
    mPath = CreateRoundPath(Left, Top, Width, Height, R1, R2, R3, R4)
    GdipGetImageThumbnail hImage, W, H, hThumb, 0&, 0&
    GdipCreateTexture hThumb, &H2, hBrush
    GdipTranslateTextureTransform hBrush, Left + Width / 2 - W / 2, Top + Height / 2 - H / 2, &H1
    GdipFillPath hGraphics, hBrush, mPath
    GdipDisposeImage hThumb
    GdipDeleteBrush hBrush
    GdipDeletePath mPath
    GdipDeleteGraphics hGraphics
End Sub

Public Function ChrW2(ByVal CharCode As Long) As String
  Const POW10 As Long = 2 ^ 10
  If CharCode <= &HFFFF& Then ChrW2 = ChrW$(CharCode) Else _
                              ChrW2 = ChrW$(&HD800& + (CharCode And &HFFFF&) \ POW10) & _
                                      ChrW$(&HDC00& + (CharCode And (POW10 - 1)))
End Function

