Bonjour,
Non, j'ai rien à demander, mais comme j'ai écris ça vite fait, je me disais que ça pouvait servir à d'autres.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127 unit UnitFileType; interface uses System.SysUtils, System.Classes, System.IOUtils, System.rtti; type TImageType = (ifUnknown, ifJPG, ifBMP, ifPNG, ifPDF, ifGIF); TRecSign = record Name: string; ImageType: TImageType; Header: array of byte; end; TRetour = reference to procedure(Rec: TRecSign); procedure ListImageTypes(Retour: TRetour); function GetFileTypename(Filename: String): string; function GetFileType(Filename: String): TImageType; function GetFileTypeStr(Filename: String): string; implementation const RecSigns: array [Succ(Low(TImageType)) .. High(TImageType)] of TRecSign = ( (Name : 'Jpeg' ; ImageType: TImageType.ifJPG; Header: [$FF, $D8, $FF, $E0]), (Name : 'Png' ; ImageType: TImageType.ifPNG; Header: [$89, $50, $4E, $47]), (Name : 'PDF' ; ImageType: TImageType.ifPDF; Header: [$25, $50, $44, $46]), (Name : 'GIF' ; ImageType: TImageType.ifGIF; Header: [$47, $49, $46, $38]), (Name : 'Bitmap'; ImageType: TImageType.ifBMP; Header: [$42, $4D]) ); procedure ListImageTypes(Retour: TRetour); var Rc: TRecSign; begin for Rc in RecSigns do Retour(Rc); end; function GetFileTypename(Filename: String): string; var RecSign: TRecSign; H: Cardinal; Bts: TBytes; Mx: NativeUInt; begin Result := ''; Mx := 0; for RecSign in RecSigns do begin if Mx < Length(RecSign.Header) then Mx := Length(RecSign.Header); end; H := FileOpen(Filename, fmOpenRead); if H <> INVALID_HANDLE_VALUE then begin SetLength(Bts, Mx); FileRead(H, Bts, 0, Mx); FileClose(H); for RecSign in RecSigns do begin if CompareMem(Bts, RecSign.Header, Length(RecSign.Header)) = True then begin Result := RecSign.Name; Break; end; end; end; end; function GetFileType(Filename: String): TImageType; var RecSign: TRecSign; H: Cardinal; Bts: TBytes; Mx: NativeUInt; begin Result := TImageType.ifUnknown; Mx := 0; for RecSign in RecSigns do begin if Mx < Length(RecSign.Header) then Mx := Length(RecSign.Header); end; H := FileOpen(Filename, fmOpenRead); if H <> INVALID_HANDLE_VALUE then begin SetLength(Bts, Mx); FileRead(H, Bts, 0, Mx); FileClose(H); for RecSign in RecSigns do begin if CompareMem(Bts, RecSign.Header, Length(RecSign.Header)) = True then begin Result := RecSign.ImageType; Break; end; end; end; end; function GetFileTypeStr(Filename: String): string; var T: TImageType; begin T := GetFileType(Filename); Result := TRttiEnumerationType.GetName(T); end; end.
Utilisable d'ailleurs avec l'unité ci-dessous qui permet créer une image en centrant une image dans une autre.
Code sans doute à améliorer, donc j'apprécie toute idée de votre part
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128 unit UnitMergeImages; interface uses Winapi.Windows, System.SysUtils, System.Classes, System.IOUtils, Vcl.Graphics, Vcl.Imaging.pngimage, Vcl.Imaging.Jpeg, Vcl.Dialogs, UnitFileType; procedure MergeAndCenter(BmpSrce: TBitmap; var BmpDest: TBitmap); overload; procedure MergeAndCenter(Filename: TFileName; var Bmp: TBitmap); overload; implementation type TMode = (mEgal, mPortrait, mPaysage); TMyGraph = class of TGraphic; procedure MergeAndCenter(BmpSrce: TBitmap; var BmpDest: TBitmap); var Mode: TMode; Rct: TRect; Ratio: Single; W, H: Integer; begin // Préparation du conteneur au format A4 BmpDest.SetSize(Trunc(210 / (25.4 / GetDeviceCaps(BmpDest.Canvas.Handle, LOGPIXELSX))), Trunc(297 / (25.4 / GetDeviceCaps(BmpDest.Canvas.Handle, LOGPIXELSY)))); if BmpSrce.Width > BmpSrce.Height then Mode := TMode.mPaysage else if BmpSrce.Width < BmpSrce.Height then Mode := TMode.mPortrait else Mode := TMode.mEgal; case Mode of mEgal: begin if BmpDest.Width > BmpSrce.Width then Ratio := 1 else Ratio := BmpDest.Width / BmpSrce.Width; W := Round(BmpSrce.Width * Ratio); H := Round(BmpSrce.Height * Ratio); end; mPaysage: begin if BmpDest.Width > BmpSrce.Width then Ratio := 1 else Ratio := BmpDest.Width / BmpSrce.Width; W := Round(BmpSrce.Width * Ratio); H := Round(BmpSrce.Height * Ratio); end; mPortrait: begin if BmpDest.Height > BmpSrce.Height then Ratio := 1 else Ratio := BmpDest.Height / BmpSrce.Height; W := Round(BmpSrce.Width * Ratio); H := Round(BmpSrce.Height * Ratio); end else begin W := 0; H := 0; end; end; Rct.SetLocation((BmpDest.Width - W) div 2, (BmpDest.Height - H) div 2); Rct.Width := W; Rct.Height := H; BmpDest.Canvas.StretchDraw(Rct, BmpSrce); end; procedure MergeAndCenter(Filename: TFileName; var Bmp: TBitmap); procedure Lt(Cls: TMyGraph); var G: TGraphic; BmpSrce: TBitmap; begin G := Cls.Create; G.LoadFromFile(Filename); if not Assigned(Bmp) then Bmp := TBitmap.Create; BmpSrce := TBitmap.Create; BmpSrce.Assign(G); MergeAndCenter(BmpSrce, Bmp); FreeAndNil(BmpSrce); FreeAndNil(G); end; begin case UnitFileType.GetFileType(Filename) of ifUnknown: raise Exception.Create('Format image non supporté! (.bmp, .jpg, .png)'); ifJPG: Lt(TJPEGImage); ifBMP: Lt(TBitmap); ifPNG: Lt(TPngImage); end; end; end.
Partager