|
|
為了給現(xiàn)有的視頻上添加幀編碼，因此需要自動形成一個自動編號的圖片序列。每一張圖片的內(nèi)容僅僅是0001,0002這樣的數(shù)字。最簡單的辦法是使用Excel在一個單元格中生成這樣的數(shù)字，然后把這個單元格的內(nèi)容復(fù)制到圖片中保存起來，就得到了所需的圖片。
經(jīng)過查詢，在網(wǎng)上找到了這樣的代碼，可以實現(xiàn)所需的功能。
代碼如下：
Option Explicit
Option Compare Text
' 用戶定義類型以便API調(diào)用
'聲明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函數(shù)聲明
'剪貼板包括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
'關(guān)閉剪貼板
Private Declare Function CloseClipboard Lib "user32" () As Long
'將句柄轉(zhuǎn)換到OLE IPicture接口里.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, _
RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'創(chuàng)建自已的metafile副本,以便不會因為隨后剪貼板的更新而擦除
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'創(chuàng)建自已的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對象
'''
''' 參數(shù): lXlPicType - 要創(chuàng)建的圖片類型,為下列類型之一:
''' xlPicture是創(chuàng)建metafile (默認(rèn))
''' xlBitmap是創(chuàng)建bitmap
'''
''' 日期 開發(fā)者 修訂記錄
''' --------------------------------------------------------------------------
''' 98年10月30日 Stephen Bullen 創(chuàng)建
''' 98年11月15日 Stephen Bullen 更新以創(chuàng)建自已的剪貼板圖像副本
'''
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常量的圖片類型轉(zhuǎn)換為API常量
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
'檢查剪貼板是否包含所需的格式
hPicAvail = IsClipboardFormatAvailable(lPicType)
If hPicAvail <> 0 Then
'獲取對剪貼板的訪問
h = OpenClipboard(0&)
If h > 0 Then
'獲取圖像數(shù)據(jù)句柄
hPtr = GetClipboardData(lPicType)
'以合適的格式創(chuàng)建自已的剪貼板中圖像的副本
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
'對其它程序釋放剪貼板
h = CloseClipboard
'如果獲取了圖像句柄,將其轉(zhuǎn)換為Picture對象并返回
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 過程: CreatePicture
'''
''' 用途: 將圖像(和調(diào)色板)句柄轉(zhuǎn)換為Picture對象.
'''
''' 需要引用"OLE Automation"類型庫
'''
''' 參數(shù): 無
'''
''' 日期 開發(fā)者 修訂記錄
''' --------------------------------------------------------------------------
''' 98年10月30日 Stephen Bullen 創(chuàng)建
'''
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
' 創(chuàng)建接口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) ' 結(jié)構(gòu)的長度.
.Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Picture類型
.hPic = hPic ' 圖像句柄
.hPal = IIf(lPicType = CF_BITMAP, hPal, 0) ' 調(diào)色板句柄(bitmap)
End With
' 創(chuàng)建Picture對象.
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
' 如果發(fā)生錯誤,則顯示錯誤描述
If r <> 0 Then Debug.Print "創(chuàng)建圖片: " & fnOLEError(r)
' 返回新的Picture對象.
Set CreatePicture = IPic
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 過程: fnOLEError
'''
''' 用途: 獲取代表標(biāo)準(zhǔn)OLE錯誤的消息文本
'''
''' 參數(shù): 無
'''
''' 日期 開發(fā)者 修訂記錄
''' --------------------------------------------------------------------------
''' 98年10月30日 Stephen Bullen 創(chuàng)建
'''
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 = " 無效參數(shù)"
Case E_NOINTERFACE
fnOLEError = " 沒有接口"
Case E_NOTIMPL
fnOLEError = " 沒有執(zhí)行"
Case E_OUTOFMEMORY
fnOLEError = " 內(nèi)存溢出"
Case E_POINTER
fnOLEError = " 無效指針"
Case E_UNEXPECTED
fnOLEError = " 未知錯誤"
Case S_OK
fnOLEError = " 成功!"
End Select
End Function
‘’‘’ 這個是要運行的主函數(shù)，存儲數(shù)據(jù)的表單名稱為PICS，從A1:Axxx存儲所需的數(shù)字。然后把這些數(shù)字保存到自動編號的位圖文件中。
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 ’數(shù)字保存在第一列中,復(fù)制到剪貼板中。
Set oPic = PastePicture(xlBitmap) '從剪貼板復(fù)制到位圖中
SavePicture oPic, vFile ‘將位圖保存。
Next
MsgBox "Done"
End Sub
使用以上的方法，可以很快生成上千個位圖文件。
|
|
