vb 整图复制
来源:互联网 发布:java打印所有水仙花数 编辑:程序博客网 时间:2024/06/05 06:15
form1
Private Sub Command_Click()
With Picture1
.AutoRedraw = True
.ScaleMode = 3
.BorderStyle = 0
DibGet .hdc, 0, 0, .ScaleWidth, .ScaleHeight
End With
With Picture2
.AutoRedraw = True
.ScaleMode = 3
.BorderStyle = 0
.Width = Picture1.Width
.Height = Picture1.Height
End With
CopyData InPutHei, InPutWid
Picture2.AutoRedraw = True
DIBPut Picture2.hdc
Picture2.Refresh
End Sub
module1
Option Explicit
'删除一个DC
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
'删除一个对象
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'获得指定类型的当前选定对象
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
'获取DIB
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 timeGetTime Lib "winmm.dll" () As Long
Public Declare Function SetDIBitsToDevice 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 Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BitMapInfo, ByVal wUsage As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Const Bits As Long = 32 '颜色深度,这里把所有图像都按照32位来处理
'文件信息头——BITMAPINFOHEADER
Private Type BitMapInfoHeader
biSize As Long '位图大小
biWidth As Long '宽度
biHeight As Long '长度
biPlanes As Integer '
biBitCount As Integer '信息头长度
biCompression As Long '压缩方式
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
'颜色表
Private Type RGBQuad
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
'rgbReserved As Byte
End Type
'位图信息头
Private Type BitMapInfo
bmiHeader As BitMapInfoHeader
bmiColors As RGBQuad
End Type
Public Done As Boolean '用于标记一个过程是否结束
Public TimeGet As Long '用于记录输入过程处理所花费的时间
Public TimePut As Long '用于记录输出过程处理所花费的时间
Dim ColVal() As Byte '用于存放从DIB输入的像素值
Dim ColOut() As Byte '用于存放向DIB输出的像素值
Public InPutHei As Long '用于记录输入图像的高度
Public InPutWid As Long '用于记录输入图像的宽度
Dim bi24BitInfo As BitMapInfo '定义BMP信息
Public Sub DibGet(ByVal IdSource As Long, XBegin As Long, ByVal YBegin As Long, ByVal XEnd As Long, ByVal YEnd As Long)
Dim iBitmap As Long
Dim iDC As Long
Dim i As Long
Dim w As Long
Dim H As Long
On Error GoTo ErrLine
Done = False
TimeGet = timeGetTime '获取系统时间
InPutWid = XEnd - XBegin
InPutHei = YEnd - YBegin
w = InPutWid + 1
H = InPutHei + 1
i = (Bits \ 8) - 1
ReDim ColVal(i, InPutWid, InPutHei)
With bi24BitInfo.bmiHeader
.biBitCount = Bits
.biCompression = 0&
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = w
.biHeight = H
End With
iBitmap = GetCurrentObject(IdSource, 7&)
GetDIBits IdSource, iBitmap, 0&, H, ColVal(0, 0, 0), bi24BitInfo, 0&
DeleteObject iBitmap
Done = True
TimeGet = timeGetTime - TimeGet
Exit Sub
ErrLine:
MsgBox "错误号:" & Err.Number & ":" & Err.Description
End Sub
Public Sub DIBPut(ByVal IdDestination As Long)
Dim w As Long
Dim H As Long
Dim LineBytes As Long
On Error GoTo ErrLine
Done = False
TimePut = timeGetTime
w = InPutWid + 1
H = InPutHei + 1
With bi24BitInfo.bmiHeader
.biWidth = w
.biHeight = H
LineBytes = ((w * Bits + 31) And &HFFFFFFE0) \ 8
.biSizeImage = LineBytes * H
End With
'SetDIBitsToDevice IdDestination, 0, 0, W, H, 0, 0, 0, H, ColOut(0, 0, 0), bi24BitInfo.bmiHeader, 0
SetDIBitsToDevice IdDestination, 0, 0, w, H, 0, 0, 0, H, ColOut(0, 0, 0), bi24BitInfo, 0
Done = True
TimePut = timeGetTime - TimePut
Exit Sub
ErrLine:
MsgBox Err.Description
End Sub
Public Sub CopyData(ByVal w As Long, ByVal H As Long)
Dim Length As Long
Dim i As Long
Dim L As Long
i = Bits \ 8
L = i - 1
Length = (w + 1&) * (H + 1&) * i
ReDim ColOut(L, w, H)
CopyMemory ColOut(0, 0, 0), ColVal(0, 0, 0), Length
End Sub
摘自一个技术馆
- vb 整图复制
- VB复制文件源代码
- Vb.net 复制类
- VB.NET复制删除文件
- VB开发——复制Excell表格
- 一个VB.NET的目录复制模块
- VB复制文件夹的方法(非FSO)
- vb.net 通过按钮复制内容
- VB.Net语言 复制、删除文件案例
- VB.Net语言 复制、删除文件
- 用VB实现将图片文件复制到剪贴板
- [VB.NET]如何实现对 RichTextBox 内容的选定、复制?
- 利用VB在Excel中复制插入行
- vb.net2008 DataTable的一行复制到新DataTable
- 【转载】 VB.NET 复制粘贴EXCEL数据到DataGridView
- VB.NET 数据表(datatable)之间的数据行复制
- 怎么用VB复制电脑上的一份EXCEL文件?
- vb生成饼图
- Zend Framework教程-Application
- 二维数组动态分配和释放 [转]
- Halcon 通过xld检测贴片
- FVWM1
- Android input handling process
- vb 整图复制
- Eclipse 插件大全介绍
- 按拼音对HashMap中的key进行排序
- NS2.3 在 fedora上的安装出现 致命错误:X11/Xlib.h:没有那个文件或目录
- LINUX 和 WINDOWS 内核的区别
- PartnerLink,PartnerLinkType详解
- docx,xlsx等在android中的type
- Oracle 关于日期时间比较、格式转化等操作
- Android4.0.3 显示系统深入理解