|
|
為了給現有的視頻上添加幀編碼，因此需要自動形成一個自動編號的圖片序列。每一張圖片的內容僅僅是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
使用以上的方法，可以很快生成上千個位圖文件。
|
|
