用Excel生成自动需要内容的图片 -

标题: 用Excel生成自动需要内容的图片 [打印本页]

作者: heicad 时间: 2016-8-12 15:34
标题: 用Excel生成自动需要内容的图片
为了给现有的视频上添加帧编码，因此需要自动形成一个自动编号的图片序列。每一张图片的内容仅仅是0001,0002这样的数字。最简单的办法是使用Excel在一个单元格中生成这样的数字，然后把这个单元格的内容复制到图片中保存起来，就得到了所需的图片。

经过查询，在网上找到了这样的代码，可以实现所需的功能。

代码如下：
Option Explicit

Option Compare Text

' 用户定义类型以便API调用

'声明UDT来为IPicture OLE接口储存GUID
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

'声明UDT储存bitmap信息
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type

'Windows API函数声明

'剪贴板包括bitmap/metafile吗?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

'打开剪贴板读取
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

'获取bitmap/metafile指针
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

'关闭剪贴板
Private Declare Function CloseClipboard Lib "user32" () As Long

'将句柄转换到OLE IPicture接口里.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, _
                     RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

'创建自已的metafile副本,以便不会因为随后剪贴板的更新而擦除
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" _
                     (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

'创建自已的bitmap副本,以便不会因为随后剪贴板的更新而擦除
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, _
                        ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

'我们要使用的API格式类型
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4

Dim vFile As Variant

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 过程: PastePicture
'''
''' 用途: 获取在剪贴板中的Picture对象
'''
''' 参数: lXlPicType - 要创建的图片类型,为下列类型之一:
'''                   xlPicture是创建metafile (默认)
'''                   xlBitmap是创建bitmap
'''
''' 日期       开发者             修订记录
''' --------------------------------------------------------------------------
''' 98年10月30日  Stephen Bullen    创建
''' 98年11月15日  Stephen Bullen    更新以创建自已的剪贴板图像副本
'''

Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture

'一些指针
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long

'将xl常量的图片类型转换为API常量
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)

'检查剪贴板是否包含所需的格式
hPicAvail = IsClipboardFormatAvailable(lPicType)

If hPicAvail <> 0 Then
      '获取对剪贴板的访问
      h = OpenClipboard(0&)

      If h > 0 Then
         '获取图像数据句柄
         hPtr = GetClipboardData(lPicType)

         '以合适的格式创建自已的剪贴板中图像的副本
         If lPicType = CF_BITMAP Then
            hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
         Else
            hCopy = CopyEnhMetaFile(hPtr, vbNullString)
         End If

         '对其它程序释放剪贴板
         h = CloseClipboard

         '如果获取了图像句柄,将其转换为Picture对象并返回
         If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
      End If
End If

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 过程: CreatePicture
'''
''' 用途: 将图像(和调色板)句柄转换为Picture对象.
'''
'''    需要引用"OLE Automation"类型库
'''
''' 参数: 无
'''
''' 日期       开发者          修订记录
''' --------------------------------------------------------------------------
''' 98年10月30日  Stephen Bullen 创建
'''

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture

' IPicture需要引用"OLE Automation"
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture

'OLE图片类型
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4

' 创建接口GUID (IPicture接口)
With IID_IDispatch
      .Data1 = &H7BF80980
      .Data2 = &HBF32
      .Data3 = &H101A
      .Data4(0) = &H8B
      .Data4(1) = &HBB
      .Data4(2) = &H0
      .Data4(3) = &HAA
      .Data4(4) = &H0
      .Data4(5) = &H30
      .Data4(6) = &HC
      .Data4(7) = &HAB
End With

' 填充uPicInfo
With uPicInfo
      .Size = Len(uPicInfo)                                                 ' 结构的长度.
      .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)  ' Picture类型
      .hPic = hPic                                                          ' 图像句柄
      .hPal = IIf(lPicType = CF_BITMAP, hPal, 0)                            ' 调色板句柄(bitmap)
End With

' 创建Picture对象.
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)

' 如果发生错误,则显示错误描述
If r <> 0 Then Debug.Print "创建图片: " & fnOLEError(r)

' 返回新的Picture对象.
Set CreatePicture = IPic

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 过程: fnOLEError
'''
''' 用途: 获取代表标准OLE错误的消息文本
'''
''' 参数: 无
'''
''' 日期          开发者             修订记录
''' --------------------------------------------------------------------------
''' 98年10月30日 Stephen Bullen    创建
'''

Private Function fnOLEError(lErrNum As Long) As String

'OLECreatePictureIndirect返回值
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Const S_OK = &H0

Select Case lErrNum
      Case E_ABORT
         fnOLEError = " 终止"
      Case E_ACCESSDENIED
         fnOLEError = " 拒绝访问"
      Case E_FAIL
         fnOLEError = " 失败"
      Case E_HANDLE
         fnOLEError = " 丢失/缺失句柄"
      Case E_INVALIDARG
         fnOLEError = " 无效参数"
      Case E_NOINTERFACE
         fnOLEError = " 没有接口"
      Case E_NOTIMPL
         fnOLEError = " 没有执行"
      Case E_OUTOFMEMORY
         fnOLEError = " 内存溢出"
      Case E_POINTER
         fnOLEError = " 无效指针"
      Case E_UNEXPECTED
         fnOLEError = " 未知错误"
      Case S_OK
         fnOLEError = " 成功!"
End Select

End Function

‘’‘’ 这个是要运行的主函数，存储数据的表单名称为PICS，从A1:Axxx存储所需的数字。然后把这些数字保存到自动编号的位图文件中。

Sub SaveDataToBMP()
Dim lPicType As Long, oPic As IPictureDisp
Dim cPath As String
Dim cName As String
Dim nRow As Integer

cPath = "D:\temp\File" ‘位图文件保存的路径为 D:\temp\, 位图文件名为Filexxxx.bmp。

For nRow = 0 To 8234
      vFile = cPath & Format(nRow, "0000") & ".bmp"
      Sheets("PICS").Range(Cells(nRow + 1, 1), Cells(nRow + 1, 1)).CopyPicture xlScreen, xlBitmap ’数字保存在第一列中,复制到剪贴板中。
      Set oPic = PastePicture(xlBitmap)  '从剪贴板复制到位图中
      SavePicture oPic, vFile       ‘将位图保存。
Next

MsgBox "Done"
End Sub

使用以上的方法，可以很快生成上千个位图文件。

欢迎光临 (http://www.51hei.com/bbs/)