Attribute VB_Name = "MyEffects"
Option Explicit

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

'----------- Verlauf ------------------------

 Public Declare Sub CopyMemory Lib "kernel32" _
  Alias "RtlMoveMemory" (Destination As Any, _
  Source As Any, ByVal Length As Long)

 Private Declare Function GradientFill Lib "msimg32" ( _
  ByVal hDC As Long, ByRef pVertex As TRIVERTEX, _
  ByVal dwNumVertex As Long, pMesh As Any, _
  ByVal dwNumMesh As Long, _
  ByVal dwMode As Long) As Integer
 
 Private Const GRADIENT_FILL_RECT_H = 0
 Private Const GRADIENT_FILL_RECT_V = 1
 
 Private Type TRIVERTEX
  X As Long
  Y As Long
  Red As Integer
  Green As Integer
  Blue As Integer
  Alpha As Integer
 End Type

 Private Type GRADIENT_RECT
  UpperLeft As Long
  LowerRight As Long
 End Type

 Dim arVert(1) As TRIVERTEX
 Dim gRect As GRADIENT_RECT
  
Sub Textur(Pic As PictureBox)
Dim X As Integer
Dim Y As Integer
Dim mRet As Long

  With Main
  .TexPic.Width = Pic.ScaleWidth
  .TexPic.Height = Pic.ScaleHeight

  Select Case Typ
  Case 0
    
    If Stil1.Check1.Value = vbChecked Then
    For Y = 0 To .TexPic.Height Step .PicRes.Height
    For X = 0 To .TexPic.Width Step .PicRes.Width
     BitBlt .TexPic.hDC, X, Y, .PicRes.Width, _
     .PicRes.Height, .PicRes.hDC, 0, 0, vbSrcCopy
    Next
    Next
    Else
     .TexPic.Cls
     .TexPic.BackColor = Main.Shape1.FillColor
     BitBlt .TexPic.hDC, Stil1.TypT(0).Text, Stil1.TypT(1).Text, .PicRes.Width, _
     .PicRes.Height, .PicRes.hDC, 0, 0, vbSrcCopy
    End If
    
  Case 1
  Call subShowGradient(.TexPic, T1, T2, CT1, CT2)
  End Select
  
  TransparentBlt .TexPic.hDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, _
  Pic.hDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, _
  Main.Shape1.FillColor
 
  .TexPic.Refresh
  Pic.Picture = .TexPic.Image
  Pic.Refresh
  End With
 
End Sub

Public Sub subShowGradient(SPic As PictureBox, sOrientation As Long, sDirection As Long, sInitialColor As Long, sFinalColor As Long)
   Dim arByteClr(3) As Byte
   Dim arByteVert(7) As Byte
   Dim iOrientation As Long
   
    On Local Error Resume Next
    
   If sDirection Then
      arVert(0).X = 0: arVert(1).X = SPic.ScaleWidth
      arVert(0).Y = 0: arVert(1).Y = SPic.ScaleHeight
   Else
      arVert(0).X = SPic.ScaleWidth:  arVert(1).X = 0
      arVert(0).Y = SPic.ScaleHeight: arVert(1).Y = 0
      End If
   
   CopyMemory arByteClr(0), sInitialColor, 4
   arByteVert(1) = arByteClr(0)
   arByteVert(3) = arByteClr(1)
   arByteVert(5) = arByteClr(2)
   CopyMemory arVert(0).Red, arByteVert(0), 8

   CopyMemory arByteClr(0), sFinalColor, 4
   arByteVert(1) = arByteClr(0)
   arByteVert(3) = arByteClr(1)
   arByteVert(5) = arByteClr(2)   '
   CopyMemory arVert(1).Red, arByteVert(0), 8


   gRect.UpperLeft = 0
   gRect.LowerRight = 1
    
   iOrientation = IIf(sOrientation, GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V)
   GradientFill SPic.hDC, arVert(0), 2, gRect, 1, iOrientation
 
   SPic.Refresh
    On Error GoTo 0
End Sub
