-
-
Notifications
You must be signed in to change notification settings - Fork 201
/
pdLayer.cls
1034 lines (807 loc) · 38.1 KB
/
pdLayer.cls
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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "pdLayer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'***************************************************************************
'PhotoDemon Image Layer class
'Copyright ©2011-2012 by Tanner Helland
'Created: 29/August/12
'Last updated: 30/September/12
'Last update: added a workaround for resizing transparent images using HALFTONE mode
'
'This marvelous class is PhotoDemon's replacement for picture boxes (which it used to store images in previous versions).
' pdLayer is a powerful DIB class responsible for managing all image data in memory. Some of the benefits provided by
' this approach include:
'
'- Ability to load large images without problems
'- Alpha channels
'- High bit depths
'- Much faster than picture boxes
'- Allows for the eventual implementation of layers and adjustment layers
'
'These are serious benefits.
'
'Note that anything you can do with an hDC property you can do with this class - simply use the getLayerDC function to
' return the DIB's hDC, then do with it what you please. All functions are heavily commented and should be self-explanatory.
'
'Note also that this class is treated as a subset of pdImage(). Right now each pdImage object only contains one layer
' (the image itself), but in the future a pdImage object could theoretically store many layers.
'
'SPECIAL THANKS
'In building this class, I utilized a number of other DIB classes for reference and testing. Special thanks to:
' Herman Liu (personal correspondence)
' Carles PV's iBMP project: http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=42376&lngWId=1
' Steve McMahon's DIB/SafeArray analysis: http://www.vbaccelerator.com/home/VB/Code/vbMedia/DIB_Sections/True_Colour_DIBSection/article.asp
' Many thanks to these three individuals for their outstanding work on graphics in VB.
'
'***************************************************************************
Option Explicit
'DIB Types
Private Type RGBQUAD
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Private Type Bitmap
Type As Long
Width As Long
Height As Long
WidthBytes As Long
Planes As Integer
BitsPerPixel As Integer
Bits As Long
End Type
Private Type BITMAPINFOHEADER
Size As Long
Width As Long
Height As Long
Planes As Integer
BitCount As Integer
Compression As Long
ImageSize As Long
XPelsPerMeter As Long
YPelsPerMeter As Long
Colorused As Long
ColorImportant As Long
End Type
Private Type BITMAPINFO
Header As BITMAPINFOHEADER
Colors(0 To 255) As RGBQUAD
End Type
Private Type BITMAPFILEHEADER
Type As Integer
Size As Long
Reserved1 As Integer
Reserved2 As Integer
OffBits As Long
End Type
'Rectangle type for use with SetRect/FillRect API calls
Private Type RECT
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type
'SafeArray types for pointing VB arrays at arbitrary memory locations (in our case, bitmap data)
Private Type SAFEARRAYBOUND
cElements As Long
lBound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(1) As SAFEARRAYBOUND
End Type
'Drawing API functions
Private Declare Function BitBlt 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 dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, ByVal hSrcDC As Long, ByVal srcX As Long, ByVal srcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal rastOp As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDestDC As Long, ByVal nStretchMode As Long) As Long
Private Const STRETCHBLT_COLORONCOLOR As Long = 3
Private Const STRETCHBLT_HALFTONE As Long = 4
'SafeArray API functions
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal byteLength As Long)
Private Declare Function VarPtrArray Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long
'DIB API functions
' (Note that these are currently declared in FastDrawing as well)
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits 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 GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function StretchDIBits 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 wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As BITMAPINFO, ByVal wUsage As Long, ByVal dwRop As Long) As Long
'DC API functions
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal HWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal HWnd As Long, ByVal hDC As Long) As Long
'Object API functions
Private Const OBJ_BITMAP As Long = 7
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObjectType Lib "gdi32" (ByVal hgdiobj As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
'Rectangle objects to be used with brushes
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private 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
'Brush creation
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
'Convert a system color (such as "button face" or "inactive window") to a literal RGB value
Private Declare Function TranslateColor Lib "OLEPRO32.DLL" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
'Clipboard interaction
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal HWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Const CLIPBOARD_FORMAT_BMP As Long = 2
Private Const CLIPBOARD_FORMAT_DIB As Long = 8
'Variables related to the DIB
'hDC for this layer
Private layerDC As Long
'DIB handle for this layer
Private layerDIB As Long
'Original handle when this layer is first created (we must store this so we can properly clean up the DIB when we're finished)
Private layerDIBOriginal As Long
'Pointer to the actual DIB bits
Private layerDIBits As Long
'Persistent DIB header; this will be used to create the DIB associated with this layer
Private layerDIBHeader As BITMAPINFOHEADER
'The layer's width and height
Private layerWidth As Long, layerHeight As Long
'The layer's array width (layerWidth * 4 for 32-bit, varies for 24-bit due to DWORD-alignment)
Private layerArrayWidth As Long
'The layer's color depth (should only ever be 24 or 32)
Private layerColorDepth As Long
'Used when writing/reading the layer data to/from a file
Private Const LAYER_IDENTIFIER As String * 4 = "PDlr"
Private Const LAYER_FILE_VERSION_2012 As Long = &H1000
'These variables are a temporary addition to ensure that print previewing still works. They will be removed in a future
' update as part of a print preview revamp, so DO NOT add features that rely on them.
Public PreviewX As Long
Public PreviewY As Long
Public PreviewWidth As Long
Public PreviewHeight As Long
'Return this layer's color depth
Public Function getLayerColorDepth() As Long
getLayerColorDepth = layerColorDepth
End Function
'Return this layer's array width
Public Function getLayerArrayWidth() As Long
getLayerArrayWidth = layerArrayWidth
End Function
'Return this layer's width
Public Function getLayerWidth() As Long
getLayerWidth = layerWidth
End Function
'Return this layer's height
Public Function getLayerHeight() As Long
getLayerHeight = layerHeight
End Function
'Return whether or not this layer has image data associated with it
Public Function hasImage() As Boolean
hasImage = (layerDIB <> 0)
End Function
'Return this layer's hDC
Public Function getLayerDC() As Long
getLayerDC = layerDC
End Function
'Return a pointer to this layer's DIB
Public Function getLayerDIB() As Long
getLayerDIB = layerDIB
End Function
'Return a pointer to this layer's pixel data
Public Function getLayerDIBits() As Long
getLayerDIBits = layerDIBits
End Function
'Copy the current layer's contents to the clipboard
Public Sub copyLayerToClipboard()
'Make sure the current layer actually contains an image before copying it to the clipboard
If (layerDIB <> 0) Then
'Make sure the clipboard is available and working
If (OpenClipboard(0) <> 0) Then
'Get a handle to the current desktop, and create a compatible clipboard device context in it
Dim desktopHWnd As Long
desktopHWnd = GetDesktopWindow
Dim desktopDC As Long, clipboardDC As Long
desktopDC = GetDC(desktopHWnd)
clipboardDC = CreateCompatibleDC(desktopDC)
'Make sure the clipboard was able to receive a compatible device context
If (clipboardDC <> 0) Then
'Create a bitmap compatible with the current desktop. This will receive the actual pixel data of the current layer
Dim clipboardBMP As Long
clipboardBMP = CreateCompatibleBitmap(desktopDC, layerWidth, layerHeight)
If (clipboardBMP <> 0) Then
'Place the compatible bitmap within the clipboard device context
Dim clipboardOldBMP As Long
clipboardOldBMP = SelectObject(clipboardDC, clipboardBMP)
'Use BitBlt to paint the current layer to that bitmap
BitBlt clipboardDC, 0, 0, layerWidth, layerHeight, layerDC, 0, 0, vbSrcCopy
'Remove that bitmap from the clipboard device context to leave room for the copy
SelectObject clipboardDC, clipboardOldBMP
'Empty the current clipboard, copy this layer into it, then close the clipboard and delete the temporary
' DC we created.
EmptyClipboard
SetClipboardData CLIPBOARD_FORMAT_BMP, clipboardBMP
'Also, add a PNG-format copy of the image if GDI+ is available
'If GDIPlusEnabled Then
'
' Dim tmpStream() As Byte
' Dim tmpIIStream As IUnknown
'
' Dim gdiCheck As Boolean
' gdiCheck = GDIPlusSavePNGStream(CurrentImage, tmpStream, tmpIIStream)
'
' Dim lPNG As Long
' lPNG = RegisterClipboardFormat("PNG")
'
' SetClipboardData lPNG, VarPtr(tmpIIStream)
'
' End If
CloseClipboard
DeleteDC clipboardDC
End If
End If
'Release (DON'T DELETE!) our control of the current desktop device context
ReleaseDC desktopHWnd, desktopDC
End If
End If
End Sub
'Make a copy of an existing layer
Public Function createFromExistingLayer(ByRef srcLayer As pdLayer, Optional ByVal newWidth As Long = -1, Optional ByVal newHeight As Long = -1, Optional useHalftoning As Boolean = True) As Boolean
'Make sure the layer we're passed isn't empty
If srcLayer.getLayerDC <> 0 Then
'Prepare new width and height values as requested by the user
If newWidth = -1 Then newWidth = srcLayer.getLayerWidth
If newHeight = -1 Then newHeight = srcLayer.getLayerHeight
'If the width and height values are not being changed, the transfer is simple
If (newWidth = srcLayer.getLayerWidth) And (newHeight = srcLayer.getLayerHeight) Then
'Create a new, blank DIB the same size as the source layer
If createBlank(srcLayer.getLayerWidth, srcLayer.getLayerHeight, srcLayer.getLayerColorDepth) Then
'Copy the image data without modification
BitBlt layerDC, 0, 0, layerWidth, layerHeight, srcLayer.getLayerDC, 0, 0, vbSrcCopy
createFromExistingLayer = True
Exit Function
End If
'If new width and height values are being specified, the transfer is a bit more complex
Else
'Create a new, blank DIB at the requested size
If createBlank(newWidth, newHeight, srcLayer.getLayerColorDepth) Then
'If either dimension of the new image will be smaller than the source, request halftoning
If useHalftoning Then
SetStretchBltMode layerDC, STRETCHBLT_HALFTONE
Else
SetStretchBltMode layerDC, STRETCHBLT_COLORONCOLOR
End If
'Resize and copy the image data
StretchBlt layerDC, 0, 0, newWidth, newHeight, srcLayer.getLayerDC, 0, 0, srcLayer.getLayerWidth, srcLayer.getLayerHeight, vbSrcCopy
'Now comes a nasty hack; HALFTONE stretching does not preserve the alpha channel, but COLORONCOLOR does. So for 32bpp
' images, we now make a second copy of the original image using COLORONCOLOR - which means it contains valid alpha values.
' Then we copy those into our current image, effectively taking the best of both HALFTONE and COLORONCOLOR stretching.
If srcLayer.getLayerColorDepth = 32 Then
Dim hackLayer As pdLayer
Set hackLayer = New pdLayer
hackLayer.createBlank newWidth, newHeight, 32
SetStretchBltMode hackLayer.getLayerDC, STRETCHBLT_COLORONCOLOR
StretchBlt hackLayer.getLayerDC, 0, 0, newWidth, newHeight, srcLayer.getLayerDC, 0, 0, srcLayer.getLayerWidth, srcLayer.getLayerHeight, vbSrcCopy
'At this point, hacklayer contains transparency data roughly equivalent to our half-toned images. (Not perfect, but close.)
' We need to copy that data into our image, then release the hack layer.
'Start, as always, with a SafeArray
Dim iData() As Byte
Dim tmpSA As SAFEARRAY2D
prepInternalSafeArray tmpSA
CopyMemory ByVal VarPtrArray(iData()), VarPtr(tmpSA), 4
'Now make a second array that points to the hacked layer alpha data
Dim aData() As Byte
Dim srcSA As SAFEARRAY2D
prepExternalSafeArray hackLayer, srcSA
CopyMemory ByVal VarPtrArray(aData()), VarPtr(srcSA), 4
Dim x As Long, y As Long, QuickX As Long
'Now loop through the image, copying alpha values as we go
For x = 0 To layerWidth - 1
QuickX = x * 4
For y = 0 To layerHeight - 1
iData(QuickX + 3, y) = aData(QuickX + 3, y)
Next y
Next x
'Decommission both arrays
CopyMemory ByVal VarPtrArray(iData), 0&, 4
CopyMemory ByVal VarPtrArray(aData), 0&, 4
'Release the temporary layer
hackLayer.eraseLayer
Set hackLayer = Nothing
End If
createFromExistingLayer = True
Exit Function
End If
End If
createFromExistingLayer = False
End If
createFromExistingLayer = False
End Function
'Give this layer a picture from a standard VB picture object
Public Function createFromPicture(ByRef srcPicture As StdPicture, Optional forceWhiteBackground As Boolean = False) As Boolean
'Make sure the picture we're passed isn't empty
If (Not srcPicture Is Nothing) Then
'Make sure the picture is actually a picture
If GetObjectType(srcPicture) = OBJ_BITMAP Then
'Select the picture's attributes into a bitmap object
Dim tmpBitmap As Bitmap
GetObject srcPicture.Handle, Len(tmpBitmap), tmpBitmap
'Use that bitmap object to create a new, blank DIB of the same size
If createBlank(tmpBitmap.Width, tmpBitmap.Height, tmpBitmap.BitsPerPixel) Then
'Create a new DC
Dim TmpDC As Long
TmpDC = CreateCompatibleDC(0)
'If successful, select the object into that DC
If TmpDC <> 0 Then
'Temporary holder for the object selection
Dim oldBitmap As Long
oldBitmap = SelectObject(TmpDC, srcPicture.Handle)
'Use BitBlt to copy the pixel data to this layer
BitBlt layerDC, 0, 0, layerWidth, layerHeight, TmpDC, 0, 0, vbSrcCopy
'Now that we have the pixel data, erase all temporary objects
SelectObject TmpDC, oldBitmap
DeleteDC TmpDC
'Finally, if the copied image contains an alpha channel (icons, PNGs, etc), it will be set against a
' black background. We want the background to be white, so perform our own premultiplication.
' (In the future, this could be a checkerboard pattern or a custom color instead of white.)
'NOTE! This is now handled at draw-time, and the instruction to re-render has been made optional.
If forceWhiteBackground And (layerColorDepth = 32) Then compositeBackgroundColor
'Success!
createFromPicture = True
Exit Function
End If
createFromPicture = False
End If
createFromPicture = False
End If
createFromPicture = False
End If
createFromPicture = False
End Function
'Create a blank layer. If no colorDepth is specified, it will default to 24bpp (16 million colors, no alpha-channel).
Public Function createBlank(ByVal iWidth As Long, ByVal iHeight As Long, Optional ByVal colorDepth As Long = 24, Optional ByVal BackColor As Long = vbWhite) As Boolean
'Erase any existing layer data
eraseLayer
'PhotoDemon only supports 24 and 32 BPP at present
If colorDepth <> 32 And colorDepth <> 24 Then
colorDepth = 24
End If
'The back color may or may not be a system color, so translate it just in case
TranslateColor BackColor, 0, BackColor
'Remember this color depth, width, and height
layerColorDepth = colorDepth
layerWidth = iWidth
layerHeight = iHeight
'Prepare the required header
With layerDIBHeader
.Size = Len(layerDIBHeader)
.Planes = 1
.BitCount = colorDepth
.Width = iWidth
.Height = -iHeight
'As always, this value needs to be a multiple of four; with 32bpp that's automatic, with 24bpp it is not
If colorDepth = 32 Then
layerArrayWidth = 4 * iWidth
Else
layerArrayWidth = (iWidth * 3 + 3) And &HFFFFFFFC
End If
.ImageSize = layerArrayWidth * iHeight
End With
'Create a new DC for use with this layer
layerDC = CreateCompatibleDC(0)
If layerDC <> 0 Then
'Create a DIB
layerDIB = CreateDIBSection(layerDC, layerDIBHeader, 0, layerDIBits, 0, 0)
'If successful, select the newly created dib into our DC
If layerDIB <> 0 Then
'We will later use layerDIBOriginal to clear up the memory associated with this layer
layerDIBOriginal = SelectObject(layerDC, layerDIB)
'Finally, set the backColor
Dim layerRect As RECT
SetRect layerRect, 0, 0, iWidth, iHeight
Dim hBrush As Long
hBrush = CreateSolidBrush(BackColor)
FillRect layerDC, layerRect, hBrush
DeleteObject hBrush
'If DIB creation failed, clear out the work we've done so far
Else
eraseLayer
End If
End If
'Return success contingent on whether we have a DIB pointer or not
createBlank = (layerDIB <> 0)
End Function
'This will effectively reset everything related to this layer, including image data. Use cautiously!
Public Function eraseLayer()
'If we have image data, clear it out
If layerDC <> 0 Then
If layerDIB <> 0 Then
SelectObject layerDC, layerDIBOriginal
DeleteObject layerDIB
End If
DeleteDC layerDC
End If
'Reset all associated DIB section variables
layerDC = 0
layerDIB = 0
layerDIBOriginal = 0
layerDIBits = 0
'Reset layer size
layerWidth = 0
layerHeight = 0
End Function
'INITIALIZE class
Private Sub Class_Initialize()
'Reset all associated DIB section variables
layerDC = 0
layerDIB = 0
layerDIBOriginal = 0
layerDIBits = 0
'Reset layer size
layerWidth = 0
layerHeight = 0
End Sub
'TERMINATE class
Private Sub Class_Terminate()
eraseLayer
End Sub
'Draw this layer to a picture box. The image will be automatically resized and centered.
Public Sub renderToPictureBox(ByRef dstPicture As PictureBox)
'Erase any existing picture
dstPicture.Picture = LoadPicture("")
'If the target picture box is smaller than this layer, request halftoning
If (dstPicture.ScaleWidth < layerWidth) Or (dstPicture.ScaleHeight < layerHeight) Then
SetStretchBltMode dstPicture.hDC, STRETCHBLT_HALFTONE
Else
SetStretchBltMode dstPicture.hDC, STRETCHBLT_COLORONCOLOR
End If
Dim dstWidth As Single, dstHeight As Single
dstWidth = dstPicture.ScaleWidth
dstHeight = dstPicture.ScaleHeight
Dim SrcWidth As Single, SrcHeight As Single
SrcWidth = layerWidth
SrcHeight = layerHeight
'Calculate the aspect ratio of this layer and the target picture box
Dim srcAspect As Single, dstAspect As Single
srcAspect = SrcWidth / SrcHeight
dstAspect = dstWidth / dstHeight
Dim dWidth As Long, dHeight As Long
If srcAspect > dstAspect Then
dWidth = dstWidth
dHeight = CSng(SrcHeight / SrcWidth) * dWidth + 0.5
PreviewY = CInt((dstHeight - dHeight) / 2)
PreviewX = 0
'PreviewWidth and PreviewHeight are only generated so that the "Print Preview" function works (it relies on those values
' to render its picture box). They will be removed in a future update so DO NOT rely on them elsewhere.
PreviewWidth = dWidth
PreviewHeight = dHeight
StretchBlt dstPicture.hDC, 0, PreviewY, dWidth, dHeight, layerDC, 0, 0, layerWidth, layerHeight, vbSrcCopy
Else
dHeight = dstHeight
dWidth = CSng(SrcWidth / SrcHeight) * dHeight + 0.5
PreviewX = CInt((dstWidth - dWidth) / 2)
PreviewY = 0
PreviewWidth = dWidth
PreviewHeight = dHeight
StretchBlt dstPicture.hDC, PreviewX, 0, dWidth, dHeight, layerDC, 0, 0, layerWidth, layerHeight, vbSrcCopy
End If
dstPicture.Picture = dstPicture.Image
dstPicture.Refresh
End Sub
'Load a layer's DIB information from file.
Public Sub createFromFile(ByRef SrcFilename As String)
Dim fileNum As Integer
fileNum = FreeFile
'Open the file and dump out only the essential information
Open SrcFilename For Binary As #fileNum
'Check to make sure this is actually a layer file
Dim LayerIDCheck As String * 4
Get #fileNum, 1, LayerIDCheck
If (LayerIDCheck <> LAYER_IDENTIFIER) Then
Close #fileNum
Message "Failed to load layer from disk: invalid layer file specified."
Exit Sub
End If
'Now check to make sure that the version number is supported (not implemented right now, because there's only one version)
Dim LayerVersionCheck As Long
Get #fileNum, , LayerVersionCheck
'Get color depth
Dim fColorDepth As Long
Get #fileNum, , fColorDepth
'Get size
Dim fWidth As Long, fHeight As Long, fArrayWidth As Long
Get #fileNum, , fWidth
Get #fileNum, , fHeight
Get #fileNum, , fArrayWidth
'Is it compressed? (Not implemented now; might be in the future)
Dim toUncompress As Boolean
Get #fileNum, , toUncompress
'If we've made it this far, attempt to load pixel data. Start by erasing and re-initializing this object to the proper size.
createBlank fWidth, fHeight, fColorDepth
'Now pull the pixel data from the file
Dim fileData() As Byte
ReDim fileData(0 To fArrayWidth - 1, 0 To fHeight - 1) As Byte
Get #fileNum, , fileData
'We're done with the file at this point, so close it
Close #fileNum
'Now it's time to overwrite our current DIB with the pixel data we pulled from the file.
'Start, as always, with a SafeArray
Dim iData() As Byte
Dim tmpSA As SAFEARRAY2D
prepInternalSafeArray tmpSA
CopyMemory ByVal VarPtrArray(iData()), VarPtr(tmpSA), 4
'Bulk copy the contents of fileData() over to iData() - which is pointing at this layer's DIB, remember
CopyMemory iData(0, 0), fileData(0, 0), fArrayWidth * fHeight
'With our work complete, point iData() away from the DIB and deallocate it
CopyMemory ByVal VarPtrArray(iData), 0&, 4
End Sub
'Write this layer's DIB information to file.
Public Sub writeToFile(ByRef DstFilename As String)
'Delete any existing file (overwrite)
If FileExist(DstFilename) = True Then Kill DstFilename
Dim fileNum As Integer
fileNum = FreeFile
'Open the file and dump out only the essential information
Open DstFilename For Binary As #fileNum
'Identifiers
Put #fileNum, 1, LAYER_IDENTIFIER
Put #fileNum, , LAYER_FILE_VERSION_2012
'Color depth
Put #fileNum, , layerColorDepth
'Size
Put #fileNum, , layerWidth
Put #fileNum, , layerHeight
Put #fileNum, , layerArrayWidth
'Is it compressed? (Not implemented now; might be in the future)
Dim toCompress As Boolean
toCompress = False
Put #fileNum, , toCompress
'And finally, the pixel data, which is presently uncompressed
Dim iData() As Byte
Dim tmpSA As SAFEARRAY2D
prepInternalSafeArray tmpSA
CopyMemory ByVal VarPtrArray(iData()), VarPtr(tmpSA), 4
'Now dump the entire array into the file. To my knowledge, this is the fastest way to do this in VB.
Put #fileNum, , iData
Close #fileNum
'With our work complete, point iData() away from the DIB and deallocate it
CopyMemory ByVal VarPtrArray(iData), 0&, 4
End Sub
'Write this layer's DIB information to a valid BMP file.
Public Sub writeToBitmapFile(ByRef DstFilename As String)
'First, make sure this layer actually contains image data
If Not Me.hasImage() Then Exit Sub
'Calculate the size of a scanline
Dim slWidth As Long
slWidth = ((layerWidth * layerColorDepth + 31) \ 32) * 4
'A valid bitmap header consists of two parts: a file header, and an image header.
Dim bmpFileHeader As BITMAPFILEHEADER
Dim bmpInfoHeader As BITMAPINFO
'Build the file header first
With bmpFileHeader
.Type = &H4D42 'BMP identifier
.Size = Len(bmpFileHeader) + (slWidth * layerHeight) 'Length of the file
.OffBits = Len(bmpFileHeader) + Len(bmpInfoHeader) 'Length of the header area
End With
'...then the image header
With bmpInfoHeader.Header
.Size = 40
.Planes = 1
.BitCount = layerColorDepth
.Width = layerWidth
.Height = layerHeight
End With
'Finally, the image bytes
Dim iData() As Byte
ReDim iData(0 To slWidth - 1, 0 To layerHeight - 1) As Byte
GetDIBits layerDC, layerDIB, 0, layerHeight, iData(0, 0), bmpInfoHeader, 0
'With all our information in place, check to see if that file already exists. Delete it if necessary.
If FileExist(DstFilename) = True Then Kill DstFilename
Dim fileNum As Integer
fileNum = FreeFile
'Open the file and dump the two headers and image data into it
Open DstFilename For Binary As #fileNum
'Headers
Put #fileNum, 1, bmpFileHeader
Put #fileNum, , bmpInfoHeader
'Image data
Put #fileNum, , iData()
Close #fileNum
End Sub
'Sometimes a layer needs to access its own bits. Here's how.
Private Sub prepInternalSafeArray(ByRef tmpSA As SAFEARRAY2D)
With tmpSA
.cbElements = 1
.cDims = 2
.Bounds(0).lBound = 0
.Bounds(0).cElements = layerHeight
.Bounds(1).lBound = 0
.Bounds(1).cElements = layerArrayWidth
.pvData = layerDIBits
End With
End Sub
'Sometimes a layer needs to access the bits of other layers. Here's how.
Private Sub prepExternalSafeArray(ByRef srcLayer As pdLayer, ByRef tmpSA As SAFEARRAY2D)
With tmpSA
.cbElements = 1
.cDims = 2
.Bounds(0).lBound = 0
.Bounds(0).cElements = srcLayer.getLayerHeight
.Bounds(1).lBound = 0
.Bounds(1).cElements = srcLayer.getLayerArrayWidth
.pvData = srcLayer.getLayerDIBits
End With
End Sub
'Pre-composite an image with an alpha-channel against a background color. Until PhotoDemon is capable of rendering transparent
' images itself, this is necessary to give transparent images a white background.
Public Sub compositeBackgroundColor(Optional ByVal newR As Long = -1, Optional ByVal newG As Long = -1, Optional ByVal newB As Long = -1)
'This is only useful for images with alpha channels. Exit if no alpha channel is present.
If layerColorDepth <> 32 Then Exit Sub
'Start, as always, with a SafeArray
Dim iData() As Byte
Dim tmpSA As SAFEARRAY2D
prepInternalSafeArray tmpSA
CopyMemory ByVal VarPtrArray(iData()), VarPtr(tmpSA), 4
Dim x As Long, y As Long, QuickX As Long
Dim checkAlpha As Byte, tmpAlpha As Single
'If no color is specified, apply a checkerboard pattern
Dim r1 As Long, g1 As Long, b1 As Long
Dim r2 As Long, g2 As Long, b2 As Long
If newR <> -1 Then
r1 = newR
r2 = newR
Else
r1 = 153
r2 = 102
End If
If newG <> -1 Then
g1 = newG
g2 = newG
Else
g1 = 153
g2 = 102
End If
If newB <> -1 Then
b1 = newB
b2 = newB
Else
b1 = 153
b2 = 102
End If
'Make sure the user didn't supply us with bad values
If r1 < 0 Then r1 = 0
If r2 < 0 Then r2 = 0
If g1 < 0 Then g1 = 0
If g2 < 0 Then g2 = 0
If b1 < 0 Then b1 = 0
If b2 < 0 Then b2 = 0
If r1 > 255 Then r1 = 255
If r2 > 255 Then r2 = 255
If g1 > 255 Then g1 = 255
If g2 > 255 Then g2 = 255
If b1 > 255 Then b1 = 255
If b2 > 255 Then b2 = 255
'Loop through the image, blending colors as we go
For x = 0 To layerWidth - 1
QuickX = x * 4
For y = 0 To layerHeight - 1
'Access the alpha data for this pixel
checkAlpha = iData(QuickX + 3, y)
'Ignore fully opaque pixels. (This makes the routine much faster.)
If checkAlpha <> 255 Then
'Convert the alpha value to a floating-point variable
tmpAlpha = CSng(checkAlpha) / 255
'Use that alpha value to blend the current colors with the newly requested color, in a checkerboard pattern
If (((x \ 8) + (y \ 8)) And 1) = 0 Then
iData(QuickX + 2, y) = Blend2Colors(iData(QuickX + 2, y), r1, tmpAlpha)
iData(QuickX + 1, y) = Blend2Colors(iData(QuickX + 1, y), g1, tmpAlpha)
iData(QuickX, y) = Blend2Colors(iData(QuickX, y), b1, tmpAlpha)
Else
iData(QuickX + 2, y) = Blend2Colors(iData(QuickX + 2, y), r2, tmpAlpha)
iData(QuickX + 1, y) = Blend2Colors(iData(QuickX + 1, y), g2, tmpAlpha)
iData(QuickX, y) = Blend2Colors(iData(QuickX, y), b2, tmpAlpha)
End If
End If
Next y
Next x
'With our compositing complete, point iData() away from the DIB and deallocate it
CopyMemory ByVal VarPtrArray(iData), 0&, 4
End Sub
'Blend byte1 w/ byte2 based on mixRatio. mixRatio is expected to be a value between 0 and 1.
Private Function Blend2Colors(ByVal Color1 As Byte, ByVal Color2 As Byte, ByRef mixRatio As Single) As Byte
Blend2Colors = (mixRatio * Color1) + ((1 - mixRatio) * Color2)
End Function
'Pre-composite an image with an alpha-channel against a background color. Until PhotoDemon is capable of rendering transparent
' images itself, this is necessary to give transparent images a white background.
Public Sub compositeBackgroundColorSpecial(ByRef srcAlpha As pdLayer, Optional ByVal newR As Long = -1, Optional ByVal newG As Long = -1, Optional ByVal newB As Long = -1)
'This is only useful for images with alpha channels. Exit if no alpha channel is present.
If layerColorDepth <> 32 Then Exit Sub
'Start, as always, with a SafeArray
Dim iData() As Byte
Dim tmpSA As SAFEARRAY2D
prepInternalSafeArray tmpSA
CopyMemory ByVal VarPtrArray(iData()), VarPtr(tmpSA), 4
'Now make a second array that points to the source alpha data
Dim aData() As Byte
Dim srcSA As SAFEARRAY2D
prepExternalSafeArray srcAlpha, srcSA
CopyMemory ByVal VarPtrArray(aData()), VarPtr(srcSA), 4
Dim x As Long, y As Long, QuickX As Long
Dim checkAlpha As Byte, tmpAlpha As Single
'If no color is specified, apply a checkerboard pattern
Dim r1 As Long, g1 As Long, b1 As Long
Dim r2 As Long, g2 As Long, b2 As Long
If newR <> -1 Then
r1 = newR
r2 = newR
Else
r1 = 153
r2 = 102
End If
If newG <> -1 Then
g1 = newG
g2 = newG
Else
g1 = 153
g2 = 102
End If
If newB <> -1 Then
b1 = newB
b2 = newB
Else
b1 = 153
b2 = 102
End If
'Make sure the user didn't supply us with bad values
If r1 < 0 Then r1 = 0
If r2 < 0 Then r2 = 0
If g1 < 0 Then g1 = 0
If g2 < 0 Then g2 = 0
If b1 < 0 Then b1 = 0
If b2 < 0 Then b2 = 0
If r1 > 255 Then r1 = 255
If r2 > 255 Then r2 = 255
If g1 > 255 Then g1 = 255
If g2 > 255 Then g2 = 255
If b1 > 255 Then b1 = 255
If b2 > 255 Then b2 = 255
'Loop through the image, blending colors as we go
For x = 0 To layerWidth - 1