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交流群 (群号:54525238) 　　　　　　Access源码网店