零售创新，创新那些事儿，SPSS，VBA

'将下列代码复制到Excel VBA模块中：

Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long

Public iClipBoardFormatNumber As Long
Dim selType As String
Dim targetFile As String
Dim fd As CommonDialog

Enum picFormat
    pic_GIFformat = 1
    pic_JPGformat = 2
    pic_PNGformat = 3
End Enum

Sub savePic(shp As Object, picFormat As picFormat, sFileName As String)
    Dim nClipsize As Long  
    Dim hMem As Long
    Dim lpData As Long 
    Dim sdata() As Byte
    selType = TypeName(shp)
    Select Case selType
        Case "ChartArea"
            shp.Parent.Export FileName:=sFileName
            Exit Sub
        Case Else
            shp.Copy
    End Select
   
    OpenClipboard 0& 
    If iClipBoardFormatNumber = 0 Then 
        For i = 40000 To 60000
            If IsClipboardFormatAvailable(i) And IsClipboardFormatAvailable(i + 1) And IsClipboardFormatAvailable(i + 2) And IsClipboardFormatAvailable(i + 3) Then
                iClipBoardFormatNumber = i
                Exit For
            End If
        Next
    End If
On Error GoTo myerror:
    hMem = GetClipboardData(iClipBoardFormatNumber + picFormat)  
    If CBool(hMem) Then
        nClipsize = GlobalSize(hMem)
        lpData = GlobalLock(hMem)
        If lpData <> 0 Then
            ReDim sdata(0 To nClipsize) As Byte
            CopyMemory sdata(0), ByVal lpData, nClipsize
            Open sFileName For Binary As #1
                Put #1, , sdata
            Close #1
        End If
        GlobalUnlock hMem
    End If

    EmptyClipboard
    CloseClipboard
    Exit Sub
myerror:
    GlobalUnlock hMem
    EmptyClipboard
    CloseClipboard
    MsgBox "export failed!"
End Sub