来源:http://202.103.176.81/drun/vbxing/
可以将 icon、Cursor、bitmap对象或者PictureBox内的图象编辑结果转换为VB的picture对象'功能 Picture对象相关操作
'类别 模块 Option Explicit'*****************************************************************
'* 将 icon 对象转换为 VB 的 picture 对象
'* 参数∶ hIcon 一个有效的图标句柄
'*****************************************************************
Function IconToPicture(ByVal hIcon As Long) As IPicture
Dim ipic As IPicture
Dim picdes As PICTDESC, iidIPicture As IID If hIcon = hNull Then Exit Function
picdes.cbSizeofstruct = Len(picdes)
picdes.picType = vbPicTypeIcon
picdes.hgdiobj = hIcon
' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
iidIPicture.Data1 = &H7BF80980
iidIPicture.Data2 = &HBF32
iidIPicture.Data3 = &H101A
iidIPicture.Data4(0) = &H8B
iidIPicture.Data4(1) = &HBB
iidIPicture.Data4(2) = &H0
iidIPicture.Data4(3) = &HAA
iidIPicture.Data4(4) = &H0
iidIPicture.Data4(5) = &H30
iidIPicture.Data4(6) = &HC
iidIPicture.Data4(7) = &HAB
OleCreatePictureIndirect picdes, iidIPicture, True, ipic
Set IconToPicture = ipic
End Function'******************************************************************
'* 将 Cursor 对象转换为 VB 的 Picture 对象
'* 参数∶ hIcon 一个有效的光标句柄
'******************************************************************
Function CursorToPicture(ByVal hIcon As Long) As IPicture
' It's just an alias
Set CursorToPicture = IconToPicture(hIcon)
End Function'******************************************************************
'* 将 bitmap 对象转换为 VB 的 picture 对象
'* 参数∶ hBmp 一个有效的位图句柄
'* hpal 一个有效的调色板句柄
'******************************************************************
Function BitmapToPicture(ByVal hBmp As Long, _
Optional ByVal hPal As Long = hNull) As IPicture
Dim ipic As IPicture
Dim picdes As PICTDESC, iidIPicture As IID
picdes.cbSizeofstruct = Len(picdes)
picdes.picType = vbPicTypeBitmap
picdes.hgdiobj = hBmp
picdes.hPalOrXYExt = hPal
' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
iidIPicture.Data1 = &H7BF80980
iidIPicture.Data2 = &HBF32
iidIPicture.Data3 = &H101A
iidIPicture.Data4(0) = &H8B
iidIPicture.Data4(1) = &HBB
iidIPicture.Data4(2) = &H0
iidIPicture.Data4(3) = &HAA
iidIPicture.Data4(4) = &H0
iidIPicture.Data4(5) = &H30
iidIPicture.Data4(6) = &HC
iidIPicture.Data4(7) = &HAB OleCreatePictureIndirect picdes, iidIPicture, True, ipic
Set BitmapToPicture = ipic
End Function'**********************************************************************
'* 刷新 PictureBox 控件的 Picture 对象。对PictureBox中的任何绘图操作,
'* 通过它即可转换为Picture对象
'* 使用该函数可将PictureBox内的图象编辑结果永久更新为 Picture 对象
'* 参数∶ PicBox PictureBox控件名
'* lWidth 需要更新的图象宽度(按你的需要,不局限于目前Picture对
'* 象的实际大小),也是最后要形成的Picture对象的图象宽度(单位∶像素)
'* lHeight 需要更新的图象高度,其他类同与 lWidth(单位∶像素)
'**********************************************************************
Function UpdatePicture(ByRef PicBox As Object, Optional ByVal lWidth As Long = -1, _
Optional ByVal lHeight As Long = -1) As Boolean
On Error GoTo errHandle Dim oldScMode As Integer
Dim hNewDC As Long
Dim hOldBit As Long
Dim hNewBit As Long oldScMode = -1
oldScMode = PicBox.ScaleMode
If lWidth = -1 Then
lWidth = PicBox.ScaleX(PicBox.Picture.Width, 8, vbPixels)
End If
If lHeight = -1 Then
lHeight = PicBox.ScaleY(PicBox.Picture.Height, 8, vbPixels)
End If hNewDC = CreateCompatibleDC(PicBox.hdc)
hNewBit = CreateCompatibleBitmap(PicBox.hdc, lWidth, lHeight)
hOldBit = SelectObject(hNewDC, hNewBit) BitBlt hNewDC, 0, 0, lWidth, lHeight, PicBox.hdc, 0, 0, vbSrcCopy
SelectObject hNewDC, hOldBit PicBox.Picture = BitmapToPicture(hNewBit) DeleteObject hNewDC
DeleteDC hNewDC
If oldScMode <> -1 Then PicBox.ScaleMode = oldScMode
UpdatePicture = True Exit Function
errHandle:
UpdatePicture = False
If oldScMode <> -1 Then PicBox.ScaleMode = oldScMode
End Function
有关的API函数声明Option ExplicitPublic Const hNull = 0Public Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End TypePublic Type PICTDESC
cbSizeofstruct As Long
picType As Long
hgdiobj As Long
hPalOrXYExt As Long
End TypePublic Declare Sub OleCreatePictureIndirect Lib "olepro32.dll" ( _
lpPictDesc As PICTDESC, _
riid As IID, _
ByVal fPictureOwnsHandle As Long, _
ipic As IPicture)
Public Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hdc As Long)
Public Declare Function CreateCompatibleBitmap& Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long)
Public Declare Function DeleteDC& Lib "gdi32" (ByVal hdc As Long)
Public Declare Function SelectObject& Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hObject As Long)
Public Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
可以将 icon、Cursor、bitmap对象或者PictureBox内的图象编辑结果转换为VB的picture对象'功能 Picture对象相关操作
'类别 模块 Option Explicit'*****************************************************************
'* 将 icon 对象转换为 VB 的 picture 对象
'* 参数∶ hIcon 一个有效的图标句柄
'*****************************************************************
Function IconToPicture(ByVal hIcon As Long) As IPicture
Dim ipic As IPicture
Dim picdes As PICTDESC, iidIPicture As IID If hIcon = hNull Then Exit Function
picdes.cbSizeofstruct = Len(picdes)
picdes.picType = vbPicTypeIcon
picdes.hgdiobj = hIcon
' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
iidIPicture.Data1 = &H7BF80980
iidIPicture.Data2 = &HBF32
iidIPicture.Data3 = &H101A
iidIPicture.Data4(0) = &H8B
iidIPicture.Data4(1) = &HBB
iidIPicture.Data4(2) = &H0
iidIPicture.Data4(3) = &HAA
iidIPicture.Data4(4) = &H0
iidIPicture.Data4(5) = &H30
iidIPicture.Data4(6) = &HC
iidIPicture.Data4(7) = &HAB
OleCreatePictureIndirect picdes, iidIPicture, True, ipic
Set IconToPicture = ipic
End Function'******************************************************************
'* 将 Cursor 对象转换为 VB 的 Picture 对象
'* 参数∶ hIcon 一个有效的光标句柄
'******************************************************************
Function CursorToPicture(ByVal hIcon As Long) As IPicture
' It's just an alias
Set CursorToPicture = IconToPicture(hIcon)
End Function'******************************************************************
'* 将 bitmap 对象转换为 VB 的 picture 对象
'* 参数∶ hBmp 一个有效的位图句柄
'* hpal 一个有效的调色板句柄
'******************************************************************
Function BitmapToPicture(ByVal hBmp As Long, _
Optional ByVal hPal As Long = hNull) As IPicture
Dim ipic As IPicture
Dim picdes As PICTDESC, iidIPicture As IID
picdes.cbSizeofstruct = Len(picdes)
picdes.picType = vbPicTypeBitmap
picdes.hgdiobj = hBmp
picdes.hPalOrXYExt = hPal
' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
iidIPicture.Data1 = &H7BF80980
iidIPicture.Data2 = &HBF32
iidIPicture.Data3 = &H101A
iidIPicture.Data4(0) = &H8B
iidIPicture.Data4(1) = &HBB
iidIPicture.Data4(2) = &H0
iidIPicture.Data4(3) = &HAA
iidIPicture.Data4(4) = &H0
iidIPicture.Data4(5) = &H30
iidIPicture.Data4(6) = &HC
iidIPicture.Data4(7) = &HAB OleCreatePictureIndirect picdes, iidIPicture, True, ipic
Set BitmapToPicture = ipic
End Function'**********************************************************************
'* 刷新 PictureBox 控件的 Picture 对象。对PictureBox中的任何绘图操作,
'* 通过它即可转换为Picture对象
'* 使用该函数可将PictureBox内的图象编辑结果永久更新为 Picture 对象
'* 参数∶ PicBox PictureBox控件名
'* lWidth 需要更新的图象宽度(按你的需要,不局限于目前Picture对
'* 象的实际大小),也是最后要形成的Picture对象的图象宽度(单位∶像素)
'* lHeight 需要更新的图象高度,其他类同与 lWidth(单位∶像素)
'**********************************************************************
Function UpdatePicture(ByRef PicBox As Object, Optional ByVal lWidth As Long = -1, _
Optional ByVal lHeight As Long = -1) As Boolean
On Error GoTo errHandle Dim oldScMode As Integer
Dim hNewDC As Long
Dim hOldBit As Long
Dim hNewBit As Long oldScMode = -1
oldScMode = PicBox.ScaleMode
If lWidth = -1 Then
lWidth = PicBox.ScaleX(PicBox.Picture.Width, 8, vbPixels)
End If
If lHeight = -1 Then
lHeight = PicBox.ScaleY(PicBox.Picture.Height, 8, vbPixels)
End If hNewDC = CreateCompatibleDC(PicBox.hdc)
hNewBit = CreateCompatibleBitmap(PicBox.hdc, lWidth, lHeight)
hOldBit = SelectObject(hNewDC, hNewBit) BitBlt hNewDC, 0, 0, lWidth, lHeight, PicBox.hdc, 0, 0, vbSrcCopy
SelectObject hNewDC, hOldBit PicBox.Picture = BitmapToPicture(hNewBit) DeleteObject hNewDC
DeleteDC hNewDC
If oldScMode <> -1 Then PicBox.ScaleMode = oldScMode
UpdatePicture = True Exit Function
errHandle:
UpdatePicture = False
If oldScMode <> -1 Then PicBox.ScaleMode = oldScMode
End Function
有关的API函数声明Option ExplicitPublic Const hNull = 0Public Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End TypePublic Type PICTDESC
cbSizeofstruct As Long
picType As Long
hgdiobj As Long
hPalOrXYExt As Long
End TypePublic Declare Sub OleCreatePictureIndirect Lib "olepro32.dll" ( _
lpPictDesc As PICTDESC, _
riid As IID, _
ByVal fPictureOwnsHandle As Long, _
ipic As IPicture)
Public Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hdc As Long)
Public Declare Function CreateCompatibleBitmap& Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long)
Public Declare Function DeleteDC& Lib "gdi32" (ByVal hdc As Long)
Public Declare Function SelectObject& Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hObject As Long)
Public Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
解决方案 »
- textout输出的位置问题
- 请问一下,我的水晶报表9在选择更多的数据源连接时,为什么没有sql server2000这一项呢?
- 各位大虾帮忙
- 大家看看这个算不算是自己给自己散分的帖子?
- 有用过tx text control 的朋友请教一下!
- 如何在VB中利用代码实现IE窗口的最小化?
- MTS的问题(欢迎交流,指导)
- VB调用自定义API函数时出现内存读地址错误
- 初学者问题,只给20分,谁先答给谁分。
- vba: object require
- microsoft Visual Basic6.0装入后出错了!??!!!
- 我很高兴,我的问题有这么多热心人解答,分数不是问题,希望和大家做朋友,可是分数怎么给你们了?
Picture1.AutoRedraw = True'再画图操作
...'保存
SavePicture Picture1.Image "c:\My.bmp"
'Picture1.AutoRedraw = True 这样画图的速度就会慢很多的
'Seedling(叶子)这个已经说的很详细了