VBA技术技巧收集
时 间:2008-02-22 07:56:31
作 者:helo ID:11 城市:上海 QQ:3002789054
摘 要:VBA技术技巧收集
正 文:
[001]在工作表中插入图片
使用Insert方法,例如,下面的代码将从Web网上相应的地址中获取图片并在当前工作表中以活动单元格为起点放置图片。
Sub InsertPicture()
ActiveSheet.Pictures.Insert“UploadFiles/2006-10/1025523341.jpg"
End Sub
同理,下面的代码将从您的计算机中的C盘相应文件夹中获取图片并在当前工作表中以活动单元格为起点放置图片。
Sub InsertPicture()
ActiveSheet.Pictures.Insert _
"C:\Documents and Settings\All Users\Documents\MyPictures\示例图片\Water lilies.jpg"
End Sub
[002]将所选单元格区域存储为图片
Private Type PicBmp
Size As Long
Type As Long
hBmp AsLong
hPal AsLong
Reserved AsLong
End Type
Private Type Guid
Data1 AsLong
Data2 AsInteger
Data3 AsInteger
Data4(0 To7) As Byte
End Type
Private Const CF_BITMAP = 2
Private Declare FunctionOleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc AsPicBmp, RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic AsIPicture) As Long
Private Declare Function GetClipboardData Lib"user32" _
(ByValwFormat As Long) As Long
Private Declare Function CloseClipboard Lib"user32" () As Long
Private Declare Function OpenClipboard Lib"user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32"Alias "FindWindowA" _
(ByVallpClassName As String, ByVal lpWindowName As String) As Long
‘- - - - - - - - - - - - - - - - - -- - - - - - -
Sub SaveImage(rng As Range, strFileNameAs String)
Dim hwnd AsLong
Dim hPtr AsLong
hwnd =FindWindow("xlmain", Application.Caption)
rng.CopyPicture xlScreen, xlBitmap
OpenClipboard hwnd
hPtr =GetClipboardData(CF_BITMAP)
SavePictureCreateBitmapPicture(hPtr), strFileName
CloseClipboard
End Sub
‘- - - - - - - - - - - - - - - - - -- - - - - - -
Function CreateBitmapPicture(ByVal hBmp As Long) As IPicture
Dim lngR AsLong, Pic As PicBmp, IPic As IPicture, IID_IDispatch As Guid
WithIID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
EndWith
WithPic
.Size = Len(Pic)
.Type = 1
.hBmp = hBmp
EndWith
lngR =OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
SetCreateBitmapPicture = IPic
End Function
‘- - - - - - - - - - - - - - - - - -- - - - - - -
Sub selectRangeToBmp()
Dim rng AsRange
Dim strNameAs String
On ErrorResume Next
Set rng =Application.InputBox(prompt:="请选择单元格区域",Title:="将单元格区域存储为图片", Type:=8)
strName =InputBox(prompt:="请输入完整路径和扩展名的文件名",Title:="输入文件名")
SaveImagerng, strName
End Sub
[代码说明]运行selectRangeToBmp()程序后,将出现两个对话框,第一个对话框要求用户选择当前工作表中想要存储为图片的单元格区域,第二个对话框要求用户输入图片的存放位置和文件名,要求写出完整的文件路径且须带.bmp或.jpg等扩展名,例如C:\<文件夹和子文件夹>\<文件名>.<扩展名
Access软件网QQ交流群 (群号:483923997) Access源码网店
使用Insert方法,例如,下面的代码将从Web网上相应的地址中获取图片并在当前工作表中以活动单元格为起点放置图片。
Sub InsertPicture()
ActiveSheet.Pictures.Insert“UploadFiles/2006-10/1025523341.jpg"
End Sub
同理,下面的代码将从您的计算机中的C盘相应文件夹中获取图片并在当前工作表中以活动单元格为起点放置图片。
Sub InsertPicture()
ActiveSheet.Pictures.Insert _
"C:\Documents and Settings\All Users\Documents\MyPictures\示例图片\Water lilies.jpg"
End Sub
[002]将所选单元格区域存储为图片
Private Type PicBmp
Size As Long
Type As Long
hBmp AsLong
hPal AsLong
Reserved AsLong
End Type
Private Type Guid
Data1 AsLong
Data2 AsInteger
Data3 AsInteger
Data4(0 To7) As Byte
End Type
Private Const CF_BITMAP = 2
Private Declare FunctionOleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc AsPicBmp, RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic AsIPicture) As Long
Private Declare Function GetClipboardData Lib"user32" _
(ByValwFormat As Long) As Long
Private Declare Function CloseClipboard Lib"user32" () As Long
Private Declare Function OpenClipboard Lib"user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32"Alias "FindWindowA" _
(ByVallpClassName As String, ByVal lpWindowName As String) As Long
‘- - - - - - - - - - - - - - - - - -- - - - - - -
Sub SaveImage(rng As Range, strFileNameAs String)
Dim hwnd AsLong
Dim hPtr AsLong
hwnd =FindWindow("xlmain", Application.Caption)
rng.CopyPicture xlScreen, xlBitmap
OpenClipboard hwnd
hPtr =GetClipboardData(CF_BITMAP)
SavePictureCreateBitmapPicture(hPtr), strFileName
CloseClipboard
End Sub
‘- - - - - - - - - - - - - - - - - -- - - - - - -
Function CreateBitmapPicture(ByVal hBmp As Long) As IPicture
Dim lngR AsLong, Pic As PicBmp, IPic As IPicture, IID_IDispatch As Guid
WithIID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
EndWith
WithPic
.Size = Len(Pic)
.Type = 1
.hBmp = hBmp
EndWith
lngR =OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
SetCreateBitmapPicture = IPic
End Function
‘- - - - - - - - - - - - - - - - - -- - - - - - -
Sub selectRangeToBmp()
Dim rng AsRange
Dim strNameAs String
On ErrorResume Next
Set rng =Application.InputBox(prompt:="请选择单元格区域",Title:="将单元格区域存储为图片", Type:=8)
strName =InputBox(prompt:="请输入完整路径和扩展名的文件名",Title:="输入文件名")
SaveImagerng, strName
End Sub
[代码说明]运行selectRangeToBmp()程序后,将出现两个对话框,第一个对话框要求用户选择当前工作表中想要存储为图片的单元格区域,第二个对话框要求用户输入图片的存放位置和文件名,要求写出完整的文件路径且须带.bmp或.jpg等扩展名,例如C:\<文件夹和子文件夹>\<文件名>.<扩展名
Access软件网QQ交流群 (群号:483923997) Access源码网店
常见问答:
技术分类:
源码示例
- 【源码QQ群号19834647...(12.17)
- 【Access小作品】简单的待...(04.30)
- 【Access窗体导出PDF】...(04.08)
- 【Access窗体导出PDF】...(04.07)
- Access两种方式实现即时更...(03.01)
- Access隐藏与显示lacc...(01.12)
- 【Access高效办公】将每个...(12.23)
- Access21点游戏源代码(12.13)
- 【Access窗体导出Exce...(11.15)
- 【Access开发】Acces...(11.14)
学习心得
最新文章
- 【Access小作品】简单的待办任...(04.30)
- 从另一个ACCESS数据库批量导入...(04.29)
- Access日期格式的数据导出Ex...(04.28)
- ACCESS精华集锦资料.CHM(04.25)
- Access VBA语句If Me...(04.24)
- 【Access修改记录示例】编辑选...(04.22)
- 【Access表名称命名建议】将A...(04.20)
- Access学习笔记--用Acce...(04.19)
- 【Access重复项查询示例】将A...(04.17)
- Access快速开发平台企业版--...(04.16)