GFMaskPrint/GFMaskPrint.frm
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3375
ClientLeft = 60
ClientTop = 345
ClientWidth = 6075
LinkTopic = "Form1"
ScaleHeight = 3375
ScaleWidth = 6075
StartUpPosition = 3 'Windows‑Standard
Begin VB.CommandButton Command1
Caption = "Test"
Height = 375
Left = 4140
TabIndex = 3
Top = 2820
Width = 1815
End
Begin VB.PictureBox PrintTargetPicture
Height = 2055
Left = 60
Picture = "GFMaskPrint.frx":0000
ScaleHeight = 1995
ScaleWidth = 5835
TabIndex = 2
Top = 600
Width = 5895
End
Begin VB.PictureBox PrintMaskPicture
AutoSize = ‑1 'True
Height = 450
Left = 600
ScaleHeight = 26
ScaleMode = 3 'Pixel
ScaleWidth = 26
TabIndex = 1
Top = 60
Width = 450
End
Begin VB.PictureBox PrintSourcePicture
AutoSize = ‑1 'True
BackColor = &H00FFFFFF&
Height = 450
Left = 60
Picture = "GFMaskPrint.frx":4B146
ScaleHeight = 26
ScaleMode = 3 'Pixel
ScaleWidth = 26
TabIndex = 0
Top = 60
Width = 450
End
Begin VB.Label Label1
Caption = "(Pointer from The Guitar)"
Height = 195
Left = 1140
TabIndex = 4
Top = 300
Width = 4815
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis.
'GFMaskPrint
Private Declare Function BitBlt Lib "gdi32.dll" (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
'GFMaskPrint_CreateMaskPicture
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
'
'NOTE: you can create a transparent bitmap using the GFMaskPrint function.
'The problem is that you need a mask picture for that, use GFMaskPrint_CreateMaskPicture()
'to automatically create a mask picture by defining one transparent color.
'
Private Function GFMaskPrint(ByVal PrintTargetPictureBox As Object, ByVal PrintTargetPictureXPos As Long, ByVal PrintTargetPictureYPos As Long, ByVal PrintSourcePictureBox As PictureBox, ByVal PrintMaskPictureBox As PictureBox) As Boolean
On Error GoTo Error: 'function returns True if printing was successful, False if not
Dim PrintMaskPictureScaleModeUnchanged As Integer
'
'NOTE: use this function to print transparent text, non‑rectangular pictures, etc.
'The mask must consist of two colors only (black and white), everything that's white will be printed.
'Print[Source/Mask] must have the picture to print placed at (0|0), and must have been made fit to
'the picture's size.
'
PrintMaskPictureScaleModeUnchanged = PrintMaskPictureBox.ScaleMode
PrintMaskPictureBox.ScaleMode = vbPixels 'important
Call BitBlt(PrintTargetPictureBox.hdc, PrintTargetPictureXPos, PrintTargetPictureYPos, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintMaskPictureBox.hdc, 0, 0, vbSrcPaint)
Call BitBlt(PrintSourcePictureBox.hdc, 0, 0, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintMaskPictureBox.hdc, 0, 0, vbMergePaint)
Call BitBlt(PrintTargetPictureBox.hdc, PrintTargetPictureXPos, PrintTargetPictureYPos, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintSourcePictureBox.hdc, 0, 0, vbSrcAnd)
PrintMaskPictureBox.ScaleMode = PrintMaskPictureScaleModeUnchanged 'reset
GFMaskPrint = True 'ok
Exit Function
Error:
If Not (PrintMaskPictureScaleModeUnchanged = 0) Then 'verify
PrintMaskPictureBox.ScaleMode = PrintMaskPictureScaleModeUnchanged 'reset
End If
GFMaskPrint = False 'error
Exit Function
End Function
Private Function GFMaskPrint_CreateMaskPicture(ByRef MaskSourcePictureBox As PictureBox, ByRef MaskTargetPictureBox As PictureBox, ByVal MaskTransparentColor As Long)
'on error resume next 'this function does not work ( :‑(======== ??? )
Dim MaskBitmapHandle As Long
Dim MaskBitmapDC As Long
'preset
'NOTE: the scale modes are not reset (to hell with twips).
MaskSourcePictureBox.ScaleMode = vbPixels
MaskTargetPictureBox.ScaleMode = vbPixels
'begin
MaskBitmapHandle = CreateBitmap(MaskTargetPictureBox.ScaleWidth, MaskTargetPictureBox.ScaleHeight, 1, 1, 0&)
MaskBitmapDC = CreateCompatibleDC(MaskTargetPictureBox.hdc)
Call SetBkColor(MaskBitmapDC, MaskTransparentColor)
Call SelectObject(MaskBitmapDC, MaskBitmapHandle)
Call BitBlt(MaskBitmapDC, 0, 0, MaskTargetPictureBox.ScaleWidth, MaskTargetPictureBox.ScaleHeight, MaskSourcePictureBox.hdc, 0, 0, vbSrcInvert)
Call BitBlt(MaskTargetPictureBox.hdc, 0, 0, MaskTargetPictureBox.ScaleWidth, MaskTargetPictureBox.ScaleHeight, MaskBitmapDC, 0, 0, vbSrcCopy)
End Function
Private Sub Command1_Click()
'on error resume next
Debug.Print PrintMaskPicture.ScaleMode
Debug.Print GFMaskPrint(PrintTargetPicture, 10, 10, PrintSourcePicture, PrintMaskPicture)
Debug.Print PrintMaskPicture.ScaleMode
Call GFMaskPrint_CreateMaskPicture(PrintSourcePicture, PrintMaskPicture, RGB(255, 255, 255))
End Sub
[END OF FILE]