transhandle.bas

回流焊监控系统-DCS,VB编写,对PLC进行通讯采集和控制,界面直观,操作方便,可以作为同类软件系统提供示范

Attribute VB_Name = "TransHandle"
Option Explicit

 ' 由于要读取位图的基本信息，所以首先要定义一个BITMAP结构的变量，然后

 ' 利用这一变量来接受位图的基本信息。

'
Type Bitmap
    Type As Long ' 位图类型
    Width As Long '宽度
    Height As Long '高度
    WidthBytes As Long '多少二进制位构成一个存储单位
    Planes As Integer '调色板数
    BitsPixel As Integer '每一个Pixel所占用的二进制位数
    Bits As Long '二进制位数据的起始位置
End Type

Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long '删除存储器DC
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long '为DC选用对象
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long '删除位图对象
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Public 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

Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public 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


'---- 过程Transparent() 复制源位图到背景的任意 X,Y 位置，使这一区域变成透明。Transparent()接受五个参数：一个将要变成透明的源位图,一个目标 picturebox控件 (PictDest), 一个RGB颜色值，另两个是你想放置原位图的目的地坐标(destX 和 destY，以像素为单位)。

Sub Transparent(ByVal sourceBmp As Long, dest As Control, ByVal _
destX As Integer, ByVal destY As Integer, ByVal TransColor As Long)
Const PIXEL = 3
Dim sourceDC As Long '源位图
Dim destScale As Long
Dim maskDC As Long 'mask位图 (monochrome)
Dim saveDC As Long '源位图的备份
Dim resultDC As Long '源位图与背景的合并
Dim invDC As Long 'Mask位图的反向图
Dim OrigColor As Long '背景色
Dim Success As Long '调用 Windows API的结果

Dim bmp As Bitmap '原位图的数据结构说明
Dim hResultBmp As Long '源与背景的位图合并
Dim hSaveBmp As Long '原位图的拷贝
Dim hSrcPrevBmp As Long
Dim hDestPrevBmp As Long
Dim hInvBmp As Long '反转掩码位图 (monochrome)
Dim hPrevBmp As Long
Dim hInvPrevBmp As Long
Dim hSavePrevBmp As Long
Dim hMaskBmp As Long
Dim hMaskPrevBmp As Long


destScale = dest.ScaleMode '保存 ScaleMode以便后面恢复
dest.ScaleMode = PIXEL '设置 ScaleMode


sourceDC = CreateCompatibleDC(dest.hdc) '建立存储器DC
saveDC = CreateCompatibleDC(dest.hdc) '建立存储器DC

invDC = CreateCompatibleDC(dest.hdc) '建立存储器DC
maskDC = CreateCompatibleDC(dest.hdc) '建立存储器DC
resultDC = CreateCompatibleDC(dest.hdc) '建立存储器DC
'接受源位图得到它的的宽度和长度 (bmp.Width ， bmp.Height)
Success = GetObject(sourceBmp, Len(bmp), bmp)
'创建单色掩码位图
hMaskBmp = CreateBitmap(bmp.Width, bmp.Height, 1, 1, ByVal 0&)
hInvBmp = CreateBitmap(bmp.Width, bmp.Height, 1, 1, ByVal 0&)

hResultBmp = CreateCompatibleBitmap(dest.hdc, bmp.Width, _
bmp.Height)
hSaveBmp = CreateCompatibleBitmap(dest.hdc, bmp.Width, _
bmp.Height)
hSrcPrevBmp = SelectObject(sourceDC, sourceBmp)
hSavePrevBmp = SelectObject(saveDC, hSaveBmp)
hMaskPrevBmp = SelectObject(maskDC, hMaskBmp)
hInvPrevBmp = SelectObject(invDC, hInvBmp)
hDestPrevBmp = SelectObject(resultDC, hResultBmp) '选择位图
Success = BitBlt(saveDC, 0, 0, bmp.Width, bmp.Height, sourceDC, _
0, 0, vbSrcCopy) '制作源位图的拷贝以便后面恢复

OrigColor = SetBkColor(sourceDC, TransColor)
Success = BitBlt(maskDC, 0, 0, bmp.Width, bmp.Height, sourceDC, _
0, 0, vbSrcCopy)
TransColor = SetBkColor(sourceDC, OrigColor)

Success = BitBlt(invDC, 0, 0, bmp.Width, bmp.Height, maskDC, _
0, 0, vbNotSrcCopy)
'拷贝背景图并创建最终的透明位图
Success = BitBlt(resultDC, 0, 0, bmp.Width, bmp.Height, _
dest.hdc, destX, destY, vbSrcCopy)

Success = BitBlt(resultDC, 0, 0, bmp.Width, bmp.Height, _
maskDC, 0, 0, vbSrcAnd)
Success = BitBlt(sourceDC, 0, 0, bmp.Width, bmp.Height, invDC, _
0, 0, vbSrcAnd)

Success = BitBlt(resultDC, 0, 0, bmp.Width, bmp.Height, _
sourceDC, 0, 0, vbSrcInvert)

Success = BitBlt(dest.hdc, destX, destY, bmp.Width, bmp.Height, _
resultDC, 0, 0, vbSrcCopy) '在背景上显示透明位图

Success = BitBlt(sourceDC, 0, 0, bmp.Width, bmp.Height, saveDC, _
0, 0, vbSrcCopy) '恢复位图
'选择对象以便释放
hPrevBmp = SelectObject(resultDC, hDestPrevBmp)
hPrevBmp = SelectObject(sourceDC, hSrcPrevBmp)
hPrevBmp = SelectObject(saveDC, hSavePrevBmp)
hPrevBmp = SelectObject(invDC, hInvPrevBmp)
hPrevBmp = SelectObject(maskDC, hMaskPrevBmp)
'释放资源
Success = DeleteDC(saveDC)
Success = DeleteDC(invDC)
Success = DeleteDC(resultDC)
Success = DeleteObject(hSaveBmp)
Success = DeleteObject(hMaskBmp)
Success = DeleteObject(hInvBmp)
Success = DeleteDC(sourceDC)
Success = DeleteDC(maskDC)

Success = DeleteObject(hResultBmp)
dest.ScaleMode = destScale '恢复 ScaleMode
End Sub