Soyez le premier à donner votre avis sur cette source.
Vue 3 916 fois - Téléchargée 469 fois
Option Explicit ' Charger l'image préparée par File2Bmp Fichier_donnée, Fichier_bmp ' dans un objet possédant une picture (propriété .. picture) ' dans cet exemple Form1 ' sauver le projet Private Sub File2Bmp(F$, BmpFile$) Dim NX%, NY%, L&, LC&, BMP$, PNG$ Dim B() As Byte, D() As Byte BMP = TMP("bmp") PNG = TMP("png") L = File2Buf(F, B): NX = Sqr((L + 4) / 48): NX = (NX - (NX = 0)) * 4 NY = 1 + (L + 3) \ (3 * NX) BM D, NX, NY CopyMemory D(54), L, 4 CopyMemory D(58), B(0), L Buf2File BMP, D If Convert(BMP, PNG, 1) = 0 Then If FileLen(PNG) < L Then L = File2Buf(PNG, B) DeleteFileA BMP: DeleteFileA PNG: DeleteFileA BmpFile NY = FreeFile Open BmpFile For Binary As NY: Put NY, , A26: Put NY, , B: Close NY End Sub Private Function TMP$(SUF$) TMP = Environ("TMP") & "\" & App.EXEName & "TMP." & SUF End Function Private Function A26$() A26 = Replace("BM: ", " ", Chr(0)) End Function Private Sub Command1_Click() Open Text2 For Output As 2: Print #2, Text1;: Close 2 End Sub Private Sub Command2_Click() File2Bmp Text2, Text3 MsgBox "Rechargez Form1.picture=" & Text3 End Sub Private Sub Form_Load() Dim A$ Form1.Picture = LoadPicture() 'supprime la picture Hidden2Str A Text1 = A Caption = App.EXEName Text2 = Caption & ".txt" Text3 = Caption & ".bmp" End Sub Private Function Hidden2Str(A$) As Boolean Dim B() As Byte Hidden2Str = Hidden2Buffer(B) If Hidden2Str Then A = StrConv(B, vbUnicode) End Function Private Function Hidden2Buffer(Buffer() As Byte) As Boolean Dim h%, I&, L&, A$ h = FreeFile Open EXEorFRX For Binary As h A = Space(LOF(h)): Get h, , A I = InStr(A, Chr(0) & A26) If I Then Get h, I - 3, L ReDim Buffer(L - 27) Get h, I + 27, Buffer Close h If Buffer(0) = 137 Then 'is PNG Buf2File TMP("png"), Buffer If Convert(TMP("png"), TMP("bmp")) = 0 Then Open TMP("bmp") For Binary As h Get h, 55, L: ReDim Buffer(L - 1): Get h, , Buffer Close h Hidden2Buffer = True End If DeleteFileA TMP("png"): DeleteFileA TMP("bmp") Else Hidden2Buffer = True End If End If End Function Private Function EXEorFRX$() EXEorFRX = App.Path If Right(EXEorFRX, 1) <> "\" Then EXEorFRX = EXEorFRX & "\" EXEorFRX = EXEorFRX & App.EXEName & IIf(DebugMode, ".frx", ".exe") End Function Private Function DebugMode() As Boolean Dim A$ A = Space(300) GetModuleFileNameA 0, A, 300 A = Left(A, InStr(A, Chr(0)) - 1) DebugMode = (LCase(Right(A, 8)) = "\vb6.exe") End Function 'et le BAS Declare Sub GetModuleFileNameA Lib "kernel32" (ByVal hModule&, ByVal lpFileName$, ByVal nSize&) Declare Sub DeleteFileA Lib "kernel32" (ByVal FileName$) Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal Length&) Declare Function GdiplusStartup& Lib "gdiplus" (Token&, inputbuf As Any, Optional ByVal outputbuf&) Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token&) Declare Function GdipLoadImageFromFile& Lib "gdiplus" (ByVal FileName$, image&) Declare Function GdipSaveImageToFile& Lib "gdiplus" (ByVal image&, ByVal FileName$, clsidEncoder As Any, encoderParams As Any) Declare Sub GdipDisposeImage Lib "gdiplus" (ByVal image&) Function Convert&(Source$, Destination$, Optional Q&) 'Q: 0Bmp 1Png 2Gif AutreQJpg Dim img&, L&(11), T&, S$, Token& L(4) = 1: If GdiplusStartup(Token, L(4)) Then Convert = 18: Exit Function Convert = GdipLoadImageFromFile(StrConv(Source, vbUnicode), img): If Convert Then Exit Function T = Q: If T = 1 Then T = 6 If Q > 2 Or Q < 0 Then T = 1: L(5) = &H1D5BE4B5: L(6) = &H452DFA4A: L(7) = &HB35DDD9C L(8) = &HEBE70551: L(9) = 1: L(10) = 4 If Q < 0 Then L(11) = VarPtr(Not Q) Else L(11) = VarPtr(Q) End If L(0) = &H557CF400 + T: L(1) = &H11D31A04: L(2) = &H739A&: L(3) = &H2EF31EF8 Convert = GdipSaveImageToFile(img, StrConv(Destination, vbUnicode), L(0), L(4)) ', ByVal 0) autre que Jpeg GdipDisposeImage img: GdiplusShutdown Token 'Convert returns: '0 Ok,GenericError,InvalidParameter,OutOfMemory '4 ObjectBusy,InsufficientBuffer,NotImplemented,Win32Error '8 WrongState,Aborted,FileNotFound,ValueOverflow '12 AccessDenied,UnknownImageFormat,FontFamilyNotFound,FontStyleNotFound '16 NotTrueTypeFont,UnsupportedGdiplusVersion,GdiplusNotInitialized,PropertyNotFound '20 PropertyNotSupported End Function Public Function BM&(T() As Byte, X%, Y%) BM = LXL(X): ReDim T(BM * Y + &H35): CopyMemory T(0), &H4D42, 2 CopyMemory T(2), BM * Y + &H36, 4: T(10) = &H36: T(14) = 40: CopyMemory T(18), X, 2 CopyMemory T(22), Y, 2: CopyMemory T(26), &H180001, 4 End Function Public Function LXL&(X) LXL = (3 * X + 3) And &H7FFC End Function Public Function File2Buf&(F$, B() As Byte) Dim h% h = FreeFile Open F For Binary As h File2Buf = LOF(h) If File2Buf Then ReDim B(File2Buf - 1): Get h, , B Else B = "" Close h End Function Public Sub Buf2File(F$, B() As Byte) Dim h% DeleteFileA F h = FreeFile Open F For Binary As h Put h, , B Close h End Sub
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.