Attribute VB_Name = "modGlobal"
'Public Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function TransparentBlt Lib "MSIMG32.dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function InvertRect Lib "user32" (ByVal hDC As Long, lpRect As RECT) As Long
Public 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 Long
Public Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal y2 As Long) As Long
Public Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
Public Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Public Declare Function CollisionDetect Lib "Collision.dll" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X1Width As Long, ByVal Y1Height As Long, ByVal Mask1LocX As Long, ByVal Mask1LocY As Long, ByVal Mask1Hdc As Long, ByVal X2 As Long, ByVal y2 As Long, ByVal X2Width As Long, ByVal Y2Height As Long, ByVal Mask2LocX As Long, ByVal Mask2LocY As Long, ByVal Mask2Hdc As Long) As Long
Public Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDrawTextParams As Any) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long

Public Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type

Public Const RDW_INVALIDATE = &H1

'LOGBRUSH lbStyle-Konstanten
Public Const BS_HATCHED = 2 'Gemusterter Brush
Public Const BS_NULL = 1 'Leerer Brush
Public Const BS_SOLID = 0 'Solider Brush
 
'LOGBRUSH lbHatch-Konstanten
Public Const HS_BDIAGONAL = 3 'Diagonal von Linksunten nach Rechtsoben (/)
Public Const HS_CROSS = 4 'Kreuz (+)
Public Const HS_DIAGCROSS = 5 'Diagonales Kreuz (x)
Public Const HS_FDIAGONAL = 2 'Diagonal von Rechtunten nach Linksoben (\)
Public Const HS_HORIZONTAL = 0 'Horizontal (-)
Public Const HS_VERTICAL = 1 'Vertikal (|)

Public Const DT_CENTER = &H1
Public Const DT_CALCRECT = &H400

Public Type RGBColor
    Red As Integer
    Green As Integer
    Blue As Integer
End Type

Public Engine As New cS2D_i
Public Effects As cS2DEffects
Public Limiter As New cS2DLimiter
Public Menu As New cS2DMenu
Public Text As New cS2DText

Public Function SplitRGB(ByVal Color As Long) As RGBColor
    
    SplitRGB.Red = (Color And &HFF)
    SplitRGB.Green = (Color And &HFFFF&) \ &H100
    SplitRGB.Blue = (Color \ &H10000)
    
End Function

Public Function IsInRect(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal y2 As Long, _
    ByVal XPos As Long, ByVal YPos As Long) As Boolean
    'Hilfsfunktion
    
    If XPos >= X1 And XPos <= X2 And YPos >= Y1 And YPos <= y2 Then
        IsInRect = True
    Else
        IsInRect = False
    End If

End Function

Public Function CheckRect(X As Integer, Y As Integer, dRect As RECT) As Boolean

    If X >= dRect.Left And X <= dRect.Left + dRect.Right And Y >= dRect.Top And Y <= dRect.Top + dRect.Bottom Then
        CheckRect = True
    Else
        CheckRect = False
    End If

End Function

Public Function SaveAsIcon(ByRef PicBox As PictureBox) As String

    Dim arrx() As String, isTr As Boolean
    Dim X As Integer, Y As Integer, s As String
    Dim tWidth As Integer, tHeight As Integer
    Dim l As Long, r As Byte, g As Byte, b As Byte
    
    tWidth = PicBox.ScaleWidth
    tHeight = PicBox.ScaleHeight
    
    ReDim arrx(tHeight - 1, 3) As String
    
    For Y = tHeight - 1 To 0 Step -1
        For X = 0 To tWidth - 1
     
        l = PicBox.Point(X, Y)
        
        r = SplitRGB(l).Red
        g = SplitRGB(l).Green
        b = SplitRGB(l).Blue
        
        If r < 0 Then r = 0
        If g < 0 Then g = 0
        If b < 0 Then b = 0
        
        If l = vbWhite Then
            s = s & Chr(0) & Chr(0) & Chr(0)
            isTr = True
        Else
            s = s & Chr(b) & Chr(g) & Chr(r)
        End If
        
        Next X
    Next Y
    
    If isTr = True Then
    
        For Y = tHeight - 1 To 0 Step -1
            For X = 0 To 3
                arrx(Y, X) = "-1"
            Next X
        Next Y
    
        For Y = 0 To tHeight - 1
            For X = 0 To tWidth - 1
            
                l = PicBox.Point(X, Y)
                If l = vbWhite Then
                  If arrx(Y, Int(X / 8)) = "-1" Then arrx(Y, Int(X / 8)) = ""
                  arrx(Y, Int(X / 8)) = arrx(Y, Int(X / 8)) & "1"
                Else
                  If arrx(Y, Int(X / 8)) = "-1" Then arrx(Y, Int(X / 8)) = ""
                  arrx(Y, Int(X / 8)) = arrx(Y, Int(X / 8)) & "0"
                End If
             
            Next X
        Next Y
    
        Dim f As String, e As Integer
        For Y = tHeight - 1 To 0 Step -1
            For X = 0 To 3
                If arrx(Y, X) = "-1" Then e = 255 Else e = TransSolution(arrx(Y, X))
                f = f & Chr(e)
            Next X
        Next Y
        
    End If
    
    s = s & f
    s = s & String(((tWidth * tWidth) * 3) + ((tWidth / 4) * tWidth) - Len(s), Chr(0))
    
    If tWidth = 16 Then
        SaveAsIcon = String(2, Chr(0)) & Chr(1) & Chr(0) & Chr(1) & Chr(0) & Chr(tWidth) & Chr(tHeight) & String(6, Chr(0)) & Chr(Val("&H68")) & Chr(3) & String(2, Chr(0)) & Chr(22) & String(3, Chr(0)) & Chr(40) & String(3, Chr(0)) & Chr(16) & String(3, Chr(0)) & Chr(32) & String(3, Chr(0)) & Chr(1) & Chr(0) & Chr(24) & String(5, Chr(0)) & Chr(64) & Chr(3) & String(18, Chr(0)) & s
    ElseIf tWidth = 32 Then
        SaveAsIcon = String(2, Chr(0)) & Chr(1) & Chr(0) & Chr(1) & Chr(0) & Chr(tWidth) & Chr(tHeight) & String(6, Chr(0)) & Chr(Val("&HA8")) & Chr(12) & String(2, Chr(0)) & Chr(22) & String(3, Chr(0)) & Chr(40) & String(3, Chr(0)) & Chr(32) & String(3, Chr(0)) & Chr(64) & String(3, Chr(0)) & Chr(1) & Chr(0) & Chr(24) & String(6, Chr(0)) & Chr(12) & String(18, Chr(0)) & s
    Else
        Err.Raise 10001, , "Unsupported Icon Size"
    End If
    
End Function

Private Function TransSolution(ByVal s As String) As Integer

    If s = "00000000" Then TransSolution = 0: Exit Function
    Dim b As Integer, C As Integer, a As String
    Dim arrBase(7) As Single
    
    For i = 7 To 0 Step -1
        a = Mid(s, i + 1, 1)
        If a = "1" Then b = 7 - i
    Next i
    
    '//////base 1
    arrBase(0) = 1
    C = -1
    For i = 0 To b
        arrBase(0) = arrBase(0) + arrBase(0)
        If i < b Then
           a = Mid(s, (7 - i) + 1, 1)
           If a = "1" Then C = i
        End If
    Next i
    '//////base 1
    
    '//////base 2
    arrBase(1) = 1
    b = -1
    For i = 0 To C
        arrBase(1) = arrBase(1) + arrBase(1)
        If i < C Then
            a = Mid(s, (7 - i) + 1, 1)
            If a = "1" Then b = i
        End If
    Next i
    '//////base 2
    
    '//////base 3
    arrBase(2) = 1
    C = -1
    For i = 0 To b
        arrBase(2) = arrBase(2) + arrBase(2)
        If i < b Then
            a = Mid(s, (7 - i) + 1, 1)
            If a = "1" Then C = i
        End If
    Next i
    '//////base 3
    
    '//////base 4
    arrBase(3) = 1
    b = -1
    For i = 0 To C
     arrBase(3) = arrBase(3) + arrBase(3)
     If i < C Then
       a = Mid(s, (7 - i) + 1, 1)
       If a = "1" Then b = i
     End If
    Next i
    '//////base 4
    
    '//////base 5
    arrBase(4) = 1
    C = -1
    For i = 0 To b
        arrBase(4) = arrBase(4) + arrBase(4)
        If i < b Then
            a = Mid(s, (7 - i) + 1, 1)
            If a = "1" Then C = i
        End If
    Next i
    '//////base 5
    
    '//////base 6
    arrBase(5) = 1
    b = -1
    For i = 0 To C
        arrBase(5) = arrBase(5) + arrBase(5)
        If i < C Then
            a = Mid(s, (7 - i) + 1, 1)
            If a = "1" Then b = i
        End If
    Next i
    '//////base 6
    
    '//////base 7
    arrBase(6) = 1
    C = -1
    For i = 0 To b
        arrBase(6) = arrBase(6) + arrBase(6)
        If i < b Then
            a = Mid(s, (7 - i) + 1, 1)
            If a = "1" Then C = i
        End If
    Next i
    If C = 0 Then arrBase(6) = arrBase(6) + 2
    '//////base 7
    
    Dim base_number As Integer
    Dim base2_number As Integer
    Dim base3_number As Integer
    Dim base4_number As Integer
    Dim base5_number As Integer
    Dim base6_number As Integer
    Dim base7_number As Integer
    
    base_number = CInt(arrBase(0) / 2)
    base2_number = CInt(arrBase(1) / 2)
    base3_number = CInt(arrBase(2) / 2)
    base4_number = CInt(arrBase(3) / 2)
    base5_number = CInt(arrBase(4) / 2)
    base6_number = CInt(arrBase(5) / 2)
    base7_number = CInt(arrBase(6) / 2)
    
    TransSolution = base_number + base2_number + base3_number + base4_number + base5_number + base6_number + base7_number
    
End Function

Public Function TransparentLine(hDC As Long, X1 As Integer, Y1 As Integer, X2 As Integer, y2 As Integer, Alpha As Integer, Color As Long)
      
    ' Bresenham Algorithm oO
    
    Dim lWidth    As Long
    Dim lHeight   As Long
    Dim D         As Long
    Dim ix        As Long
    Dim iy        As Long
    Dim dd        As Integer
    Dim ID        As Integer
    
    Dim pixel As Long
    Dim pixel2 As Long

    lWidth = X2 - X1
    lHeight = y2 - Y1
    D = 0
    
    If lWidth < 0 Then
        lWidth = -lWidth
        ix = -1
    Else
        ix = 1
    End If
    
    If lHeight < 0 Then
        lHeight = -lHeight
        iy = -1
    Else
        iy = 1
    End If
    
    If lWidth > lHeight Then
        dd = lWidth + lWidth
        ID = lHeight + lHeight
        
        Do
            pixel = GetPixel(hDC, X1, Y1)
            pixel2 = AlphaColor(pixel, Color, Alpha)
            SetPixel hDC, X1, Y1, pixel2
            
            If X1 = X2 Then Exit Do
            X1 = X1 + ix
            D = D + ID
            
            If D > lWidth Then
                Y1 = Y1 + iy
                D = D - dd
            End If
        Loop
    
    Else
        dd = lHeight + lHeight
        ID = lWidth + lWidth
    
        Do
            pixel = GetPixel(hDC, X1, Y1)
            pixel2 = AlphaColor(pixel, Color, Alpha)
            SetPixel hDC, X1, Y1, pixel2
            
            If Y1 = y2 Then Exit Do
            Y1 = Y1 + iy
            D = D + ID
            
            If D > lHeight Then
                X1 = X1 + ix
                D = D - dd
            End If
        Loop
    End If
    
End Function

Public Function AlphaColor(Color1 As Long, Color2 As Long, Alpha As Integer) As Long
    
    Dim te As RGBColor
    Dim ta As RGBColor
    Dim ti As RGBColor
    Dim tAlpha As Integer

    ta = SplitRGB(Color1)
    te = SplitRGB(Color2)

    tAlpha = (255 - Alpha) '/ 255
    
    ti.Red = te.Red + (((ta.Red - te.Red) * tAlpha) / 255)
    ti.Blue = te.Blue + (((ta.Blue - te.Blue) * tAlpha) / 255)
    ti.Green = te.Green + (((ta.Green - te.Green) * tAlpha) / 255)
    
    If ti.Red < 0 Then ti.Red = 0
    If ti.Green < 0 Then ti.Green = 0
    If ti.Blue < 0 Then ti.Blue = 0
    If ti.Red > 255 Then ti.Red = 255
    If ti.Green > 255 Then ti.Green = 255
    If ti.Blue > 255 Then ti.Blue = 255

    AlphaColor = rgb(CInt(ti.Red), CInt(ti.Green), CInt(ti.Blue))
    
End Function

Public Function GetFilePath(FileNa As String) As String

    Dim FRes As String
    Dim SLen As Integer
    SLen = Len(FileNa)
    LstPos = 0


    For i = 1 To SLen
        SepPos = InStr(i, FileNa, "\", 1)


        If SepPos > LstPos And (i) < SLen Then
            LstPos = SepPos
        Else
            SepPos = LstPos '+ 1 'i + 1
            Exit For
        End If

        i = SepPos 'i + (SepPos - 1)
    Next i

    FRes = Left(FileNa, SepPos)
    GetFilePath = FRes
End Function

Public Function Snap(Cordinate As Variant, Dimension As Integer) As Integer
    Snap = (Cordinate \ Dimension) * Dimension
End Function
