Soyez le premier à donner votre avis sur cette source.
Snippet vu 4 543 fois - Téléchargée 47 fois
Private Const BI_RGB = 0& Private Const DIB_RGB_COLORS = 0 ' color table in RGBs Private Type BITMAPINFOHEADER '40 bytes biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long 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 Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private 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 Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Dim iBitmap As Long, iDC As Long Public Sub CreateEff(Eff As String, OrgHdc As Long, vW As Single, vH As Single, Newhdc As Long) On Error Resume Next Dim bi24BitInfo As BITMAPINFO, bBytes() As Byte, Cnt As Long With bi24BitInfo.bmiHeader .biBitCount = 24 .biCompression = BI_RGB .biPlanes = 1 .biSize = Len(bi24BitInfo.bmiHeader) .biWidth = vW .biHeight = vH End With ReDim bBytes(1 To bi24BitInfo.bmiHeader.biWidth * bi24BitInfo.bmiHeader.biHeight * 4) As Byte iDC = CreateCompatibleDC(OrgHdc) iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&) SelectObject iDC, iBitmap BitBlt iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, OrgHdc, 0, 0, vbSrcCopy GetDIBits iDC, iBitmap, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS Select Case Eff Case "Inverse" For Cnt = LBound(bBytes) To UBound(bBytes) bBytes(Cnt) = 255 - bBytes(Cnt) Next Cnt Case "Ombre" For Cnt = LBound(bBytes) To UBound(bBytes) bBytes(Cnt) = bBytes(Cnt) * 0.5 Next Cnt Case "Cellule" For Cnt = LBound(bBytes) To UBound(bBytes) mutip = Tan(Abs(Cos(Abs(((Cnt * 50) / (15)))))) / 1.5 If Int(bBytes(Cnt) * mutip) > 255 Then bBytes(Cnt) = (bBytes(Cnt)) Else bBytes(Cnt) = Int(bBytes(Cnt) * mutip) End If Next Cnt Case "Confus" For Cnt = LBound(bBytes) To UBound(bBytes) mutip = (bBytes(Cnt)) Xor 25 bBytes(Cnt) = mutip Next Cnt Case "Clear" For Cnt = LBound(bBytes) To UBound(bBytes) Step 3 mutip = bBytes(Cnt) * 0.9 bBytes(Cnt) = (mutip) Next Cnt Case "Blue" For Cnt = LBound(bBytes) To UBound(bBytes) Step 3 bBytes(Cnt + 1) = 0 bBytes(Cnt + 2) = 0 Next Cnt Case "Green" For Cnt = LBound(bBytes) To UBound(bBytes) Step 3 bBytes(Cnt) = 0 bBytes(Cnt + 2) = 0 Next Cnt Case "Red" For Cnt = LBound(bBytes) To UBound(bBytes) Step 3 bBytes(Cnt) = 0 bBytes(Cnt + 1) = 0 Next Cnt Case "Soft" For Cnt = LBound(bBytes) To UBound(bBytes) Step 3 bBytes(Cnt) = GetMin(bBytes(Cnt) * Tan(Abs(Cos(Cnt * 2)))) bBytes(Cnt + 1) = GetMin(bBytes(Cnt + 1) * Tan(Abs(Cos(Cnt * 2)))) bBytes(Cnt + 2) = GetMin(bBytes(Cnt + 2) * Tan(Abs(Cos(Cnt * 2)))) Next Cnt Case "Change" For Cnt = LBound(bBytes) To UBound(bBytes) Step 3 mbd = bBytes(Cnt) mvd = bBytes(Cnt + 1) mrd = bBytes(Cnt + 2) bBytes(Cnt) = mvd bBytes(Cnt + 1) = mrd bBytes(Cnt + 2) = mbd Next Cnt Case "Noir et Blanc" For Cnt = LBound(bBytes) To UBound(bBytes) Step 3 mbd = bBytes(Cnt) mvd = bBytes(Cnt + 1) mrd = bBytes(Cnt + 2) bBytes(Cnt) = mvd bBytes(Cnt + 1) = mvd bBytes(Cnt + 2) = mvd Next Cnt Case "Dark" For Cnt = LBound(bBytes) To UBound(bBytes) - 3 Step 3 bBytes(Cnt) = bBytes(Cnt) * Cnt / UBound(bBytes) bBytes(Cnt + 1) = bBytes(Cnt + 1) * Cnt / UBound(bBytes) bBytes(Cnt + 2) = bBytes(Cnt + 2) * Cnt / UBound(bBytes) Next Cnt End Select SetDIBitsToDevice Newhdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, 0, 0, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS DeleteDC iDC DeleteObject iBitmap End Sub Public Function GetMin(v1) GetMin = v1 If v1 > 255 Then GetMin = 255 End If If v1 < 0 Then GetMin = 0 End If End Function
Donc je mets 10 pour remonter cette note ridicule !
DarK Sidious
g po dit qu'c'était une prouesse Mémère, je disais ça pour moi, pour m'excuser et montrer ma sincérité...
t po un peu râleur toi aussi ? :)
tchao à tous VBistes, @+
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.