本类文章的标签为 ‘Windows API’


让Excel自动响应消息框中的提示

1 颗星2 颗星3 颗星4 颗星5 颗星 (目前还没有人投票)
Loading ... Loading ...

这是以前收录的一段程序示例:
使用VBA在调用工作簿中打开被调用工作簿,并运行其中的宏。该宏将弹出一个消息框,如果用户没有响应,那么程序会在指定时间后自动响应。
调用工作簿中的程序代码如下:

Public Declare Function SetTimer& Lib "user32" (ByVal hwnd&, _
    ByVal nIDEvent&, ByVal uElapse&, ByVal lpTimerFunc&)
Private Declare Function KillTimer& Lib "user32" (ByVal hwnd&, _
    ByVal nIDEvent&)
Public Const NV_INPUTBOX As Long = &H5000
 
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    SendKeys "%Y"
    KillTimer hwnd, idEvent
End Sub
 
Sub test()
 
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
 
    Dim targetworkbook As Workbook
 
    Dim usersave As VbMsgBoxResult
 
    Set targetworkbook = Workbooks.Open("C:\test2.xls", UpdateLinks:=0)
 
    Calculate
    targetworkbook.Activate
    SetTimer 0, NV_INPUTBOX, 1000, AddressOf TimerProc
    Application.Run targetworkbook.Name & "!tester"
 
    targetworkbook.Activate
 
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
 
End Sub

假设被调用工作簿存储在C盘,工作簿名为test2.xls,那么其中的代码如下:

Sub tester()
    TimedMsgBox
End Sub
 
Sub TimedMsgBox()
    Dim cTime As Long
    Dim WSH As Object
 
    Set WSH = CreateObject("WScript.Shell")
    cTime = 5 '5 秒
    Select Case WSH.Popup("Open an Excel file?!", cTime, "Question", vbOKCancel)
        Case vbOK
            MsgBox "你单击了确定"
        Case vbCancel
            MsgBox "你单击了取消"
        Case -1
            MsgBox "超时"
    End Select
End Sub

运行调用工作簿中的程序后,被调用的工作簿test2.xls会被打开,并运行其中的程序,该程序会弹出一个消息框,如果用户没有响应该消息框,那么在5秒后,会自动响应,即弹出一个内容为“超时”的消息框。

相关文章

使用注册表API保存和恢复设置

1 颗星2 颗星3 颗星4 颗星5 颗星 (目前还没有人投票)
Loading ... Loading ...

本文来源于Microsoft知识库文章How To Use the Registry API to Save and Retrieve Setting,仅供参考。
虽然VB包括用来从注册表中保存和恢复信息的函数SaveSetting和GetSetting,但是这些函数仅操作注册表的特定部分,即HKEY_CURRENT_USER根键下的Visual Basic and VBA Program Settings。
下面的内容介绍了可以用于从注册表的任意位置设置和恢复值的32位Windows API函数。
注册表概述
应用程序和Windows使用注册表存储配置数据,取代了Windows 3.x中大量的INI文件。注册表使用像树一样的键和值的层级系列来组织。每个键都以六个预定义的根键开始,具有与其相关的子键和值。这些键是有组织的且命名的单元,像文件的文件夹一样出现在Windows注册表编辑器中。值是数据项,作为文本项出现在注册表编辑器窗口的右侧。键不需要有相关的值,但可能也有很多相关的值,每个值有一个相关的数据类型。两个最常用的注册表数据类型是:REG_SZ,一个空结尾的字符串;REG_DWORD,一个32位数值。
用于从注册表的某位置写或读的基本过程是相同的。要引用任何提供的键或值,必须有一个对该键的句柄。一旦获得了该项句柄,这个句柄指定的键的值和子键可以被读取、设置或列举(枚举)。
提供了注册表中的某位置,要获取该键的句柄,必须以六个预定义键开始(HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CURRENT_CONFIG, and HKEY_DYN_DATA),展开注册表树直至到达期望的键。用户程序最经常从HKEY_CURRENT_USER and HKEY_LOCAL_MACHINE中读和写。如果某注册表键已经存在,那么可以使用对RegOpenKey或RegOpenKeyEx函数的一系列调用。如果需要创建注册表键,那么就使用RegCreateKey和RegCreateKeyEx函数。
使用期望的键的句柄,这些函数用于列出、设置和恢复要调用的信息。在所有情况下,带有Ex后缀的函数仅能在32位平台中使用,没有后缀的函数可以在16位和32位Windows中使用。注意,不是所有没有“Ex”后缀的注册表函数都是为16位兼容所提供的,Ex后缀仅添加在16位函数的功能被扩展的函数里。全新的且专为32位平台的函数不具有Ex扩展。
RegSetValue和RegSetValueEx函数允许修改值的设置,RegQueryValue和RegQueryValueEx函数检索值的当前设置。这里,这些非Ex、16位版的APIs的局限是非常明显的。当使用16位的RegSetValue函数时,没有办法命名值,因此RegSetValue不能用于与每个键的多个值相关联。此外,所有使用RegSetValue写入的值具有REG_SZ数据类型。这些局限是16位注册表固有的。RegSetValueEx允许创建具有任何可用数据类型的多个值。
如何写入指定的注册表位置
确定需要使用的函数后,从下文中复制相关的声明,并粘贴到标准模块。所包含的两个VB过程封装了RegSetValueEx和RegQueryValueEx API函数,极大地简化了其使用。下面利用了这些VB函数,然而,如果愿意则可以自由地直接调用API。
1、创建/修改键和值
使用可用的声明和过程,可以创建和打开键,并且添加、修改和读取值。下面介绍如何创建键,设置或修改值,以及查询值。
2、创建新键
使用下面的过程很容易创建新键。CreateNewKey过程接受要创建的键名,以及代表要创建的键下预定义键的常量。对RegCreateKeyEx的调用没有利用安全机制允许,但可以修改,这已经超出了本文讨论的范围。

Private Sub CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)
    Dim hNewKey As Long         '新键的句柄
    Dim lRetVal As Long         'RegCreateKeyEx函数的结果

    lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, _
                 vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
                 0&, hNewKey, lRetVal)
    RegCloseKey (hNewKey)
End Sub

使用下面的语句调用该过程:

CreateNewKey "TestKey", HKEY_LOCAL_MACHINE

立即在HKEY_LOCAL_MACHINE下创建一个名为TestKey的键。
使用下面的语句调用该过程:

CreateNewKey "TestKey\SubKey1\SubKey2", HKEY_LOCAL_MACHINE

立即在HKEY_LOCAL_MACHINE下以TestKey开始创建三层嵌套的键,SubKey1隶属于TestKey,SubKey3在SubKey2之下。
3、设置/修改值
使用下面简单的过程就可以成功创建和设置指定键的值。SetKeyValue过程接受相关值的键、值的名称、值的设置、以及值的类型(SetValueEx函数仅支持REG_SZ和REG_DWORD,但如果需要可以修改)。为已存在的sValueName指定新值将修改该值的当前设置。

Private Sub SetKeyValue(sKeyName As String, sValueName As String, _
   vValueSetting As Variant, lValueType As Long)
    Dim lRetVal As Long      'SetValueEx函数的结果
    Dim hKey As Long         '打开键的句柄

    '打开指定的键
    lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, _
                                 KEY_SET_VALUE, hKey)
    lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
       RegCloseKey (hKey)
End Sub

调用代码如下:

SetKeyValue "TestKey\SubKey1", "StringValue", "Hello", REG_SZ

创建一个名为“StringValue”的REG_SZ类型的值,其设置为“Hello”,该值将与TestKey的SubKey1键相关。
此时,“TestKey”是HKEY_CURRENT_USER的子键,但可以通过改变对RegOpenKeyEx的调用来修改。如果“TestKey\SubKey1”不存在,那么该调用将失败。为了避免这类问题,使用对RegCreateKeyEx的调用来代替对RegOpenKeyEx的调用。如果已经存在的话,RegCreatKeyEx将打开指定的键。
4、查询值
下面的过程可以用于确定现有值的设置。QueryValue过程接受键的名称和与该键相关的值的名称,并且显示一个带有相应值的消息框。使用了对下面定义的QueryValueEx封装函数的调用,仅支持REG_SZ和REG_DWORD类型。

Private Sub QueryValue(sKeyName As String, sValueName As String)
    Dim lRetVal As Long      'API函数的结果
    Dim hKey As Long         '打开的键的句柄
    Dim vValue As Variant      '查询的值的设置

    lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, _
       KEY_QUERY_VALUE, hKey)
    lRetVal = QueryValueEx(hKey, sValueName, vValue)
    MsgBox vValue
    RegCloseKey (hKey)
End Sub

使用下面的语句调用该过程:

QueryValue "TestKey\SubKey1", "StringValue"

显示一个带有“StringValue”值的当前设置的消息框,假设在“TestKey\SubKey1”键中存在“StringValue”。
如果查询的值不存在,那么QueryValue将返回错误代码:2-’ERROR_BADKEY’。
5、其他
上面的示例专门使用了扩展的32位版本的注册表函数,这些函数允许每个键关联多个值。正如上面所讲述的,16位的RegSetValue和RegQueryValue只作用于当前键相关的单个值(总是REG_SZ类型)。这些函数在32位注册表编辑器中显示为。要设置、修改或查询这个特定相关的值,必须使用16位注册表函数。从16位环境的注册表中读和写比32位环境更简单。相同的基本过程如下:打开键,获取句柄,然后调用修改函数处理该句柄,但是无须考虑多个相关的值或不同的值的数据类型。16位应用程序可以使用RegCreateKey、RegOpenKey、RegQueryValue、RegSetValue和RegCloseKey的声明来创建和修改键和值。
有时,不需要与某键相关的多个值,应用程序可能仅需要知道是否存在某个键或值,不会关心键的值的性质。此时,可以使用RegEnumKey、RegEnumKeyEx和RegEnumValue函数确定是否存在某个键或值。
API函数和常量声明

  Public Const REG_SZ As Long = 1
  Public Const REG_DWORD As Long = 4
 
  Public Const HKEY_CLASSES_ROOT = &H80000000&
  Public Const HKEY_CURRENT_USER = &H80000001&
  Public Const HKEY_LOCAL_MACHINE = &H80000002&
  Public Const HKEY_USERS = &H80000003&
 
  Public Const ERROR_NONE = 0
  Public Const ERROR_BADDB = 1
  Public Const ERROR_BADKEY = 2
  Public Const ERROR_CANTOPEN = 3
  Public Const ERROR_CANTREAD = 4
  Public Const ERROR_CANTWRITE = 5
  Public Const ERROR_OUTOFMEMORY = 6
  Public Const ERROR_ARENA_TRASHED = 7
  Public Const ERROR_ACCESS_DENIED = 8
  Public Const ERROR_INVALID_PARAMETERS = 87
  Public Const ERROR_NO_MORE_ITEMS = 259
 
  Public Const KEY_QUERY_VALUE = &H1
  Public Const KEY_SET_VALUE = &H2
  Public Const KEY_ALL_ACCESS = &H3F
 
  Public Const REG_OPTION_NON_VOLATILE = 0
 
  Declare Function RegCloseKey Lib "advapi32.dll" _
   (ByVal hKey As Long) As Long
  Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
   "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
   ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _
   As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _
   As Long, phkResult As Long, lpdwDisposition As Long) As Long
  Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
   "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
   ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As _
   Long) As Long
  Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
   String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
   As String, lpcbData As Long) As Long
  Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
   String, ByVal lpReserved As Long, lpType As Long, lpData As _
   Long, lpcbData As Long) As Long
  Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
   String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
   As Long, lpcbData As Long) As Long
  Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
   "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
   String, ByVal cbData As Long) As Long
  Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
   "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
   ByVal cbData As Long) As Long

SetValueEx和QueryValueEx封装函数:

Public Function SetValueEx(ByVal hKey As Long, sValueName As String, _
   lType As Long, vValue As Variant) As Long
    Dim lValue As Long
    Dim sValue As String
    Select Case lType
        Case REG_SZ
            sValue = vValue & Chr$(0)
            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, _
                                              lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, _
                   lType, lValue, 4)
    End Select
End Function
 
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
   String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String
 
    On Error GoTo QueryValueExError
 
    ' 确定读取的数据类型和大小
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5
 
    Select Case lType
        ' 字符串
        Case REG_SZ:
            sValue = String(cch, 0)
 
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
                   sValue, cch)
            If lrc = ERROR_NONE Then
                   vValue = Left$(sValue, cch - 1)
            Else
                   vValue = Empty
            End If
        ' DWORDS
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
                 lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue
        Case Else
            '所有不支持的其它数据类型
            lrc = -1
    End Select
 
QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
 
QueryValueExError:
     Resume QueryValueExExit
End Function

相关文章

在VBA中使用Windows API

1 颗星2 颗星3 颗星4 颗星5 颗星 (1 人投票, 平均: 5.00 out of 5)
Loading ... Loading ...

VBA是一种强大的编程语言,可用于自定义Microsoft Office解决方案。通过使用VBA处理一个或多个Office应用程序对象模型,可以容易地修改Office应用程序的功能或者能够使两个或多个Office应用程序协同工作以完成单个应用程序无法完成的任务。然而,使用VBA仅能控制操作系统的一小部分。Windows API提供了控制操作系统绝大多数方面的功能。下面,介绍在VBA中使用Windows API的一些知识。
理解APIs
API只是一组函数,可用于处理组件、应用程序或操作系统。通常,API由一个或多个提供某种特定功能的DLLs组成。
DLLs是包含函数的文件,能够从任何运行的Windows应用程序中调用DLLs。在运行时,DLL中的函数被动态链接到调用它的应用程序里。无论多少应用程序调用DLL中的函数,该函数仅存在于磁盘的单个文件中,并且DLL在内存中仅被创建一次。
您可能最经常听说的API是Windows API,它包括组成Windows操作系统的DLLs。每个Windows应用程序都直接或间接地与Windows API相交互,Windows API确保运行在Windows下的所有应用程序都按一致的方式工作。
除了Windows API外,还有其它发布的APIs可用。例如,邮件应用程序编程接口(MAPI)是一组用于编写电子邮件应用程序的DLLs。
APIs通常是由创建Windows应用程序的C和C++程序员编写,但能够使用VBA调用DLL中的函数。因为大多数DLLs最初都是由C/C++程序员编写和文档规范,所以调用DLL函数与调用VBA函数不同。为了使用API,必需理解如何传递参数到DLL函数。
为了调用Windows API中的函数,需要描述这些可用的函数的文档规范,如何在VBA中声明这些函数,以及如何调用它们。下面是两个有用的资源:
1、Win32API.txt文件,包含Windows API中大多数函数的VBA Declare(声明)语句。可以使用API Viewer加载宏查找和复制需要的Declare语句。可以在下面的站点下载API声明查看器:
http://www.activevb.de/rubriken/apiviewer/index-apiviewereng.html
也可以在此下载:

win32api.txt文件下载:

2、Microsoft Platform SDK,包含复杂的Windows API文档。可以在下面的地址中查看:http://msdn.microsoft.com/en-us/library/aa383750(VS.85).aspx
此外,很多程序员还开发了一些声明并与大家共享,下面就是一个关于API声明的资源网站:http://www.xcelfiles.com/
使用Declare语句
在从VBA中调用DLL里的函数之前,必须为VBA提供在哪里找到函数以及如何调用该函数的信息,有两种方法:
1、设置对DLL类型库的引用。
2、在模块中使用Declare语句。
设置对DLL类型库的引用是使用DLL中的函数的最容易的方法。一旦设置引用,就可以将其当作工程里的一部分一样调用DLL函数。然而,也要注意一些事项。首先,设置对多个类型库的引用会影响应用程序的性能;其次,不是所有的DLLs都提供类型库,虽然可以对没有提供类型库的DLL设置引用,但不能调用该DLL中的函数。
注意,组成Windows API的DLLs没有提供类型库,因此不能设置对它们的引用并调用其中的函数。要调用Windows API中的函数,必须在工程里模块的声明部分包括Declare语句。
Declare语句是一个定义,告诉VBA在哪里找到特定的DLL函数以及如何调用该函数。在代码中添加Declare语句最简单的办法是使用API Viewer加载宏,其中包含Windows API中大多数函数的Declare语句,也包含一些函数所需要的常量和类型定义。
Declare语句声明的形式如下:

[Public|Private]Declare Sub name Lib "libname" [Alias "aliasname"][([arglist])]
[Public|Private]Declare Function name Lib "libname" [Alias "aliasname"] [([arglist])] [As type]

下面是GetTempPath函数的Declare语句的示例,该函数返回Windows临时文件夹的路径(默认为C:\Windows\Temp):

Private Declare Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long

关键字Declare告诉VBA在工程中要包含的DLL函数的定义。在标准模块中的Declare语句可以是公共的或私有的,取决于你希望API函数仅用于单个模块还是整个工程。在类模块中,Declare语句必须是私有的。
在关键字Function之后是函数的名字,具体地说,是从VBA中调用该函数时使用的名字。这个名字可以与API函数本身的名字相同,也可以在Declare语句中使用关键字Alias指定打算在VBA中通过不同的名字(别名)调用该函数。
在上面的示例中,在DLL中API函数的名字是GetTempPathA,从VBA中调用该函数时使用的名字是GetTempPath。注意,DLL函数的实际名字出现在关键字Alias之后,同时也注意到GetTempPath是Win32API.txt文件用于该函数的别名,但你可以将其改变为任何你想要的名字。
下面是为什么要在Declare语句中使用别名的一些理由:

  • 一些API函数的名字以下划线(_)开始,在VBA中是不合乎语法的。为了从VBA中调用该函数,需要使用别名。
  • 因为别名允许将DLL函数命名为你所希望的名字,所以可以使函数名字遵循你自已在VBA中的命名标准。
  • 因为API函数是区分大小写的,而VBA函数则不,所以可以使用别名来改变函数名的大小写。
  • 一些DLL函数带有接受不同数据类型的参数,这些函数的VBA声明语句定义这些参数为类型Any,调用带有声明为Any的参数的DLL函数是危险的,因为VBA不会执行任何数据类型检查。如果想避免传递类型为Any的参数的危险,可以声明相同的DLL函数的多个版本,每一个都具有不同的名字和不同的数据类型。
  • Windows API为所有接受字符串参数的函数都包含两个版本:ANSI版和Unicode版。ANSI版带有“A”后缀,正如上例所示,而Unicode版带有“W”后缀。虽然VBA使用Unicode,但在调用DLL中的函数之前,它将所有的字符串转换为ANSI字符串,因此在从VBA中调用Windows API函数时通常使用ANSI版。API Viewer加载宏自动为所有接受字符串参数的函数命名别名,因此可以不必包含“A”后缀而调用该函数。

关键字Lib指定包含函数的DLL。注意,在声明语句里以字符串形式包含DLL的名字。如果在系统中没有找到关键字Lib之后指定的DLL,对该函数的调用将失败,导致运行时错误:48,装载DLL错误。因为可以在VBA代码中处理这种错误,所以可以编写健壮的代码得体地处理错误。
下面列出了Windows API中最常使用的DLLs:

  • Kernel32.dll:低级别的操作系统函数,例如内存管理和资源处理。
  • User32.dll:Windows管理函数,例如消息处理、计时器、菜单和通讯。
  • GDI32.dll:图像设备接口(GDI)库,包含设置输出的函数,例如绘图、显示上下文和字体管理。

大多数DLLs,包括Windows API中的DLLs,都采用C/C++编写,因此,传递参数到DLL函数需要参数的理解以及C/C++接受的数据类型,而这些不同于VBA函数。
同时,DLL函数的许多参数按值传递。默认情况下,VBA中的参数按引用传递。因此,当DLL函数需要按值传递的参数时,在函数定义中包括关键字ByVal是必要的。在函数定义中忽略ByVal关键字可能会在应用程序中导致无效的页错误。有时,可能会发生VBA运行时错误:49,坏的DLL调用协议。
按引用传递参数传递该参数的内存位置到被调用的过程,如果该过程修改了参数的值,那么会修改该参数的唯一的副本,因此,当返回到调用过程时,参数包含的是修改后的值。
按值传递参数到DLL函数,将传递该参数的副本,函数操作该参数的副本,避免了修改实际参数的内容。当返回到调用过程时,该参数包含与调用其它过程前相同的值。
因为按引用传递允许在内存中修改参数值,如果不恰当地按引用传递参数,DLL函数可能会覆盖它不应该覆盖的内存,导致错误或者不可预料的结果。Windows维护许多值不应该被覆盖,例如,Windows为每个窗口赋惟一的32位标识符,称作句柄(handle)。句柄总是按值传递给API函数,因为如果Windows修改了某窗口的句柄,那么不再能够追踪到该窗口。(虽然关键字ByVal出现在String类型的一些参数前面,但是字符串总是按引用被传递到Windows API函数)
上述声明语句接受两个参数,一个为Long型,另一个为String型,并返回一个Long型值。
使用常量
除了DLL函数的声明语句外,一些函数还需要定义常量以及在函数中使用的类型。在模块的声明部分包括常量和用户定义类型。
如何知道函数需要的常量和用户定义类型呢?需要查看该函数的文档。Win32API.txt文件包含函数的常量和用户定义类型的定义。可以使用API Viewer加载宏找出这些常量和用户定义类型,并将它们复制到代码中。不巧的是,常量和用户定义类型不会以任何方式与需要它们的声明语句相联系,因此,仍然需要检查DLL函数的文档,决定哪个常量和类型与哪个声明语句匹配。
函数可能需要传递常量来指明想要函数返回的信息。例如,GetSystemMetrics函数接受75个常量,每一个都指定操作系统的不同方面,该函数返回的信息取决于传递给它的常量。要调用GetSystemMetrics,不需要包括所有的75个常量,只需包括要使用的就可以了。
建议定义常量而不是简单地传递它们代表的值。Microsoft确保在将来的版本中仍然会保留相同的常量,但不保证常量的值相同。
DLL函数需要的常量通常是隐含的,因此需要查阅函数的文档来确定传递的常量,以返回特定的值。
在《Professional Excel Development》中介绍了如何查找常量的值的方法。即在Microsoft的站点下载并安装核心SDK软件包,其中有一个名为“include”的子目录,所有用于创建动态链接库(DLL)的C++头文件都存放在这个目录中。通过搜索就能找到常量所在的文件,例如查找SM_CXSCREEN,会返回文件“winuser.h”,打开该文件查询就可找到相关的常量。
下面的示例是包括GetSystemMetrics函数的声明语句,接受两个常量,然后展示如何从属性过程中调用GetSystemMetrics,以像素为单位返回屏幕的高度。

Declare Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
Const SM_CXSCREEN As Long = 0 '屏幕宽度
Const SM_CYSCREEN As Long = 1 '屏幕高度

Public Property Get ScreenHeight() As Long
    '以像素为单位返回屏幕的高度
    ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
End Property
 
Public Property Get ScreenWidth() As Long
    '以像素为单位返回屏幕的宽度
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Property

使用用户定义类型
用户定义类型是一种数据结构,可以存储多个相关的不同类型的变量,与C/C++中的结构一致。有时,传递空的用户定义类型到DLL函数,函数填充值;有时,从VBA填充用户定义类型,并将其传递给DLL函数。
可以将用户定义类型作为一箱抽屉,每个抽屉可以包含不同类型的项目,但将它们组合在一起可以当作相关项目的单个箱子。可以从任何抽屉获得项目而不必担心存储在任何其它抽屉中的项目。
要创建用户定义类型,使用Type … End Type语句。在Type…End Type语句里,列出了每个项目,包含值和数据类型。用户定义类型的元素可以是数组。
下面的代码段展示如何定义RECT用户定义类型,和管理屏幕矩形块的几个Windows API函数一起使用。例如,GetWindowRect函数接受RECT类型的数据结构,使用关于窗口的左侧、顶部、右侧和底部位置的信息填充。

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

要传递用户定义类型到DLL函数,必须创建该类型的变量。例如,如果打算传递RECT类型的用户定义类型到DLL函数,那么就要包括变量声明,如下所示:

Private rectWindow As RECT

可以引用用户定义类型里的单个元素,如下所示:

Debug.Print rectWindow.Left

使用句柄
调用DLLs中的函数之前需要理解的另一个重要的概念是句柄(handle)。简单地说,句柄是32位正整数,Windows用于识别窗口或另一个对象,例如字体或位图。
在Windows中,窗口有许多不同的表现形式。事实上,在屏幕中看到的几乎所有事情都在窗口里,并且不能看到的大多数事情也在窗口里。窗口能够是一个绑定的屏幕矩形区域,就像您习惯看到的应用程序窗口一样。窗体中的控件,例如列表框或滚动条,也都是窗口,虽然不是所有类型的控件都是窗口。在桌面上显示的图标以及桌面本身,都是窗口。
因为所有这些类型的对象都是窗口,所以Windows能够相同地对待它们。Windows提供给每个窗口一个唯一的句柄,并使用该句柄去处理窗口。许多API函数返回句柄或者接受句柄作为其参数。
当窗口创建时Windows赋句柄给该窗口,当窗口销毁时Windows释放该句柄。虽然句柄保留的时间与窗口存在的时间相同,但不保证一个窗口在销毁并重新创建后有相同的句柄。因此,如果在变量中存储句柄,那么记住该窗口销毁后,该句柄不再有效。
GetActiveWindow函数是返回窗口句柄的函数示例,此时,应用程序窗口是当前活动的窗口。GetWindowText函数接受某窗口的句柄,并且如果窗口有标题的话返回该窗口的标题。下面的程序使用GetActiveWindow返回活动窗口的句柄,GetWindowText返回其标题:

Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function GetWindowText Lib "user32" _
    Alias "GetWindowTextA" (ByVal Hwnd As Long, _
    ByVal lpString As String, ByVal cch As Long) As Long
 
Function ActiveWindowCaption() As String
    Dim strCaption As String
    Dim lngLen As Long
    '创建使用空字符填充的字符串
    strCaption = String$(255, vbNullChar)
    '返回字符串的长度
    lngLen = Len(strCaption)
    '调用GetActiveWindow来返回活动窗口的句柄
    '与字符串和其长度一起,传递句柄到GetWindowText
    If (GetWindowText(GetActiveWindow, strCaption, lngLen) > 0) Then
        '返回Windows已写入的值给字符串
        ActiveWindowCaption = strCaption
    End If
End Function

GetWindowText函数接受三个参数:窗口的句柄、将返回窗口标题里的空结尾的字符串、以及字符串的长度。
下面列出了Excel中常用的窗口类名称:

  • Excel主窗口:XLMAIN
  • Excel桌面:XLDESK
  • Excel工作表:EXCEL7
  • Excel用户窗体:ThunderDFrame(Excel 2000以后版本)、ThunderRT6DFrame(Excel 2000以后版本,用于作为COM加载项时)、ThunderXFrame(Excel 97)
  • Excel状态栏:EXCEL4
  • Excel图表窗口:EXCELE(Excel2007以前版本)

FindWindow函数使用类名和窗口标题查找窗口。下面的代码以像素为单位查找Excel主窗口的位置和大小:

'包含窗口大小的用户定义类型
Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
'查找窗口的API函数
Declare Function FindWindow Lib "user32" _
        Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
 
'获取窗口大小的API函数
Declare Function GetWindowRect Lib "user32" ( _
        ByVal hWnd As Long, _
        lpRect As RECT) As Long
 
Sub ShowExcelWindowSize()
    Dim hWnd As Long, uRect As RECT
    '获取Excel主窗口的句柄
    'Excel 2002及以后版本也可使用hWnd=Application.Hwnd
    hWnd = FindWindow("XLMAIN", Application.Caption)
    '将窗口大小信息存入到RECT结构中
    GetWindowRect hWnd, uRect
    '显示结果
    MsgBox "这个Excel窗口的尺寸为:" & _
        vbCrLf & "左侧:" & uRect.Left & _
        vbCrLf & "右侧:" & uRect.Right & _
        vbCrLf & "顶部:" & uRect.Top & _
        vbCrLf & "底部:" & uRect.Bottom & _
        vbCrLf & "宽度:" & (uRect.Right - uRect.Left) & _
        vbCrLf & "高度:" & (uRect.Bottom - uRect.Top)
End Sub

调用函数
虽然调用DLL函数的许多方式与调用VBA函数相似,但是开始时有一些不同可能会使DLL函数混淆。下面将介绍如何输入DLL函数中的参数并加前缀、如何返回字符串、如何传递数据结构、能够接受什么返回值、以及如何获取错误信息。
参数数据类型
在C/C++中使用的数据类型、用于描述它们的标记都不同于在VBA中的用法,下面描述了DLL函数中常用的数据类型以及它们在VBA中的等效表示。



C/C++数据类型 匈牙利前缀 描述 等效的VBA表示
BOOL b 8位布尔值。0表示False;非0表示True Boolean或Long
BYTE ch 8位无符号整数 Byte
HANDLE h 32位无符号整数,代表Windows对象的句柄 Long
int n 16位符号整数 Integer
long l 32位符号整数 Long
LP lp 32位对内存中C/C++结构、字符串、函数或其它数据的长指针 Long
LPZSTR lpsz 32位对C类型空结尾字符串的长指针 Long

虽然您应该熟悉这些数据类型和前缀,但前面提到的Win32API.txt文件包含了准备在VBA中使用的声明语句。如果在代码中使用这些声明语句,那么函数参数已经定义了正确的VBA数据类型。
在《Excel 2007 VBA参考大全》的第27章,详细介绍了如何将C-样式声明转换为VBA声明语句。
只要已经定义并传递了正确的数据类型,调用DLL函数与调用VBA函数采取相同的方法。当然也有例外,这将在下面的内容中介绍。
从DLL函数中返回字符串
DLL函数不会以VBA函数相同的方法返回字符串。因为字符串总是按引用传递到DLL函数,DLL函数能够修改字符串参数的值。宁可返回字符串作为函数的返回值,就像可能在VBA中做的那样,DLL函数返回字符串到传递给该函数的String类型的参数。函数的实际返回值经常是一个长整型值,指定写入到字符串参数的字节数量。
接受字符串参数的DLL函数获得指针,指向内存中该字符串的位置。指针只是内存地址,表明在哪里存储字符串。因此,当从VBA中传递字符串到DLL函数时,传递给DLL函数一个指针,指向内存中的字符串。接着,这个DLL函数修改存储在那个地址的字符串。
要调用写到String变量的DLL函数,需要采取额外的步骤合适地格式字符串。首先,String变量必须是空结尾字符串。一个空结尾字符串以特定的空字符结束,空字符通过VBA常量vbNullChar来指定。
其次,DLL函数不能修改已经创建的字符串的大小。因此,需要确保传递给函数的字符串足够大以容纳整个返回值。当传递字符串到DLL函数中时,通常需要指定在另一个传递的参数中字符串的大小。Windows追踪字符串的长度,以确保不会覆盖掉字符串已使用过的内存。
传递字符串到DLL函数中的一个好方法是创建String变量,并使用String$函数在其中填充空字符,使其足够大以容纳函数返回的字符串。例如,下面的代码创建一个144字节长的字符串,并使用空字符串填充:

Dim strTempPath As String
strTempPath = String$(144, vbNullChar)

当传递字符串到DLL函数中时,如果不知道字符串的长度,那么可以使用Len函数确定其长度。
获取Windows临时文件夹的GetTempPath函数,就是返回String值的DLL函数的例子。该函数接受两个参数,一个空结尾的字符串变量和一个包含字符串长度的数值变量。修改该字符串以便包含路径,例如C:\Temp\。(Windows需要一个临时文件夹存在,于是该函数应该总是返回该文件夹的路径。如果由于某种原因不存在临时文件夹,GetTempPath返回0)。
下面的程序调用GetTempPath函数获取Windows临时文件夹的路径:

Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
    (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
 
Property Get GetTempFolder() As String
    '返回用户临时文件夹的路径.
    '对于根目录,Windows需要一个临时文件夹存在
    '因此应该总是返回其路径
    '以防万一,检查GetTempPath的返回值
    Dim strTempPath As String
    Dim lngTempPath As Long
    '使用空字符填充字符串
    strTempPath = String(144, vbNullChar)
    '获得字符串的长度
    lngTempPath = Len(strTempPath)
    '调用GetTempPath,传递字符串长度和字符串
    If (GetTempPath(lngTempPath, strTempPath) > 0) Then
        'GetTempPath返回路径到字符串中.
        '截去字符串开始的空字符
        GetTempFolder = Left(strTempPath, InStr(1, strTempPath, vbNullChar) - 1)
    Else
        GetTempFolder = ""
    End If
End Property

注意,当传递字符串到函数中时,使用空字符填充该字符串。函数写入返回的字符串值“C:\Temp”到字符串变量的第一部分中,并且剩下的保留空字符填充,接着使用Left函数截取字符串。
GetTempPath函数的实际返回值是已经被写到字符串变量中的字符数。如果返回的字符串是“C:\Temp\”,那么GetTempPath函数返回8。
注意,这仅对从函数返回字符串时传递空结尾字符串及其大小是必需的。如果函数不返回字符串到字符串参数中,而是接受对函数指定信息的字符串,那么只需传递正常的VBA字符串变量。
传递用户定义类型到DLL函数
许多DLL函数需要通过使用预定义的格式传递数据结构。当从VBA中调用DLL函数时,根据函数的需求传递已经定义的用户定义类型。
通过查看函数的声明语句,您能够理解什么时候需要传递用户定义类型以及需要在代码中包括哪种类型定义。需要数据结构的参数总是被声明为长指针:指向内存中数据结构的32位数字值。为长指针参数约定的前缀是“lp”。此外,参数的数据类型是数据结构的名称。
例如,看看GetLocalTime函数和SetLocalTime函数的声明语句:

Private Declare Sub GetLocalTime Lib "kernel32" _
    (lpSystem As SYSTEMTIME)
Private Declare Function SetLocalTime Lib "kernel32" _
(lpSystem As SYSTEMTIME) As Long

两个函数都接受SYSTEMTIME类型的参数,即包含日期和时间信息的数据结构。下面是SYSTEMTIME类型的定义:

Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

要将数据结构传递给函数,必须声明SYSTEMTIME类型的变量,如下所示:

Private sysLocalTime As SYSTEMTIME

当调用GetLocalTime时,传递SYSTEMTIME类型的变量到该函数,并且使用表示当前本地的年、月、日、星期几、小时、分、秒、毫秒的数字值填充该数据结构。例如,下面的Property Get程序调用GetLocalTime返回表明当前小时的值:

Public Property Get Hour() As Integer
    '返回当前时间,然后返回小时
    GetLocalTime sysLocalTime
    Hour = sysLocalTime.wHour
End Property

当调用SetLocalTime时,也传递了SYSTEMTIME类型的变量,但首先提供数据结构的一个或多个元素的值。例如,下面的Property Let程序设置本地系统时间的小时值。首先,调用GetLocalTime函数获取本地时间的当前值到数据结构中,然后使用传递给属性过程的值更新数据结构的sysLocalTime.wHour的值。最后,调用SetLocalTime函数,传递相同的数据结构,包含通过GetLocalTime加新小时值而取得的值。

Public Property Let Hour(intHour As Integer)
    '获取当前时间以便所有值都是当前的
    '然后设计本地时间的小时部分
    GetLocalTime sysLocalTime
    sysLocalTime.wHour = intHour
    SetLocalTime sysLocalTime
End Property

GetLocalTime函数和SetLocalTime函数与GetSystemTime函数和SetSystemTime函数相似。主要的不同在于,GetSystemTime函数和SetSystemTime函数表达的时间为格林威治标准时间。例如,如果本地时间是午夜12时,而您居住在西海岸,那么格林威治标准时间就是上午8时,有8小时的时差。GetSystemTime函数返回当前时间即8:00 A.M,而GetLocalTime返回午夜12:00。
理解Any数据类型
一些带有一个参数的DLL函数可以接受多个数据类型。在DLL函数的声明语句中,这样的参数被声明为类型Any。VBA允许传递任何数据类型到这个参数。然而,DLL函数可能被设计为接受仅仅两个或三个不同的数据类型,因此传递错误的数据类型可能会导致应用程序错误。
通常,当在VBA工程中编译代码时,VBA对传递给每个参数的值执行类型检查。也就是说,确保传递的值的数据类型与函数定义中的参数的数据类型相匹配。例如,如果参数定义为Long型,而试图传递String型的数值,则会发生编译时错误。这适用于调用内置的VBA函数、用户定义函数、或者DLL函数。当将参数声明为类型Any时,不会进行类型检查,因此当传递值到这种类型的参数时应该谨慎。
一些具有一个参数的DLL函数可以接受字符串或者指向字符串的空指针。指向字符串的空指针是一个特别的指针,指令Windows忽略所给的参数。它与零长度字符串(“”)不同。在VBA的早期版本中,程序员必须声明参数为类型Any,或者声明DLL函数的两个版本,即一个版本定义参数类型为String,一个版本定义参数类型为Long。现在VBA包括vbNullString常量,代表指向字符串的空指针,这样可以声明参数为String类型,并且在需要传递空指针的情形下传递vbNullString常量。
获取错误信息
DLL函数中发生的运行时错误的行为不同于VBA中的运行时错误,即没有错误消息框显示。当运行时错误发生时,DLL函数返回某值表时发生了错误,而且错误不会中断VBA代码的执行。
Windows API中的一些函数存储运行时错误的错误信息。如果使用C/C++编程,可以使用GetLastError函数获取关于发生的最后一次错误的信息。然而,从VBA中,GetLastError函数可能返回不确切的结果。要从VBA获得关于DLL错误的信息,可以使用VBA的Err对象的LastDLLError属性。LastDLLError属性返回发生的错误号。
为了使用LastDLLError属性,需要知道与错误相对应的错误号。在Win32API.txt文件没有这方面的可用信息,而Microsoft Platform SDK中可以找到。
下面的示例展示在已经调用了Windows API中的函数后如何使用LastDLLError属性。PrintWindowCoordinates程序接受窗口句柄,并调用GetWindowRect函数。GetWindowRect使用组成窗口的矩形的边的长度填充RECT数据结构。如果传递了无效的句柄,将发生错误,并且可以通过LastDLLError属性获得错误号。

Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
                lpRect As RECT) As Long
 
Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Const ERROR_INVALID_WINDOW_HANDLE As Long = 1400
Const ERROR_INVALID_WINDOW_HANDLE_DESCR As String = "无效的窗口句柄."
 
Sub PrintWindowCoordinates(hwnd As Long)
    '以像素为单位打印窗口左侧,右侧,顶部和底部位置
    Dim rectWindow As RECT
    '传递窗口句柄和空的数据结构
    '如果函数返回0,那么错误就发生了
    If GetWindowRect(hwnd, rectWindow) = 0 Then
        '因为传递了无效的句柄
        '所以如果发生错误则检查LastDLLError并显示对话框
        If Err.LastDllError = ERROR_INVALID_WINDOW_HANDLE Then
            MsgBox ERROR_INVALID_WINDOW_HANDLE_DESCR, _
                Title:="错误!"
        End If
    Else
        Debug.Print rectWindow.Bottom
        Debug.Print rectWindow.Left
        Debug.Print rectWindow.Right
        Debug.Print rectWindow.Top
    End If
End Sub

要获得活动窗口的坐标,可以通过使用GetActiveWindow函数返回活动窗口的句柄,并将结果传递到前面示例定义的过程中。要使用GetActiveWindow函数,包括下面的声明语句:

Declare Function GetActiveWindow Lib "user32" () As Long

输入下面的过程后运行:

Sub test()
    PrintWindowCoordinates (GetActiveWindow)
End Sub

要生成一条错误消息,随便使用一个长整型数值调用这个过程。

参考资源:
David Shank,《Office VBA and the Windows API
Excel 2007 VBA参考大全
《Professional Excel Development》
《VBA and Macros for Microsoft Excel》

相关文章

从Excel中导出图片

1 颗星2 颗星3 颗星4 颗星5 颗星 (1 人投票, 平均: 5.00 out of 5)
Loading ... Loading ...

前不久,有两位朋友都提出过类似的问题:

  • 问题1 请问能否将从工作表中截获的图片(对Range进行了CopyPicture操作)直接放入UserForm的TextBox里(该窗体并非在工作表中建立的,而是在工程中建立的)?如果不可行,有无其他方式实现?
  • 问题2 同样对于一个Range进行了CopyPicture和Paste操作后,能否将截获的图片直接放入单元格的批注中?在实现过程中是否必须要将截获的图片导出并保存为图片格式(比如gif)的文件后,才能再对批注进行Fill操作?若不可行,有无其他方式实现?
  • 问题3 将Excel多个选定的数据区域分别导出为图片的VBA代码

其实,问题的关键在于如何获取Excel工作表中的图片供使用。在Excel中,Chart对象有一个Export方法,能够直接将图形以图像方式导出到本地计算机上,例如将工作表Sheet1中的第1个图表导出为GIF图像并保存到C:盘,其VBA代码为:

Worksheets("Sheet1").ChartObjects(1) .Chart.Export _
    FileName:="C:\MyChart.gif", FilterName:="GIF"

然而,有时候我们需要将工作表中的图片(Picture)或形状(Shape)导出到文件夹中,此时就没那么容易了。我尝试过将图片或形状复制到Excel图表区域(先使图表区域为空,再将图片复制到此区域),然后再使用其Export方法将图片导出,但没有成功(这是一个思路,不知道哪位朋友试过且成功了,可以在这里与大家分享)。
没办法,只好使用Windows API了,在查阅了一些图书和资料后,终于找到了这样的代码。在这里,将通用的代码贴出来,与大家分享。同时,以简单的示例代码演示其使用方法。

示例1:将Excel单元格区域复制为图片,然后从剪贴板中取出该图片并放入单元格批注中
这是《Excel 2007 VBA参考大全》作者之一Stephen Bullen编写的一段通用代码,您可以将其当作通用模块在自已的工程中使用(当然,您不必理解其含义,能用就行了,呵呵……)。
ModPastePicture模块代码:

'***************************************************************************
'*
'* 模 块 名 称:   粘贴图片
'* 作者 & 日期:   STEPHEN BULLEN, Office Automation Ltd
'*                1998年11月15日
'*
'* 联 系 方 式:   Stephen@oaltd.co.uk
'* 网 站 地 址:   http://www.oaltd.co.uk
'*
'* 说       明:   从剪贴板中创建标准的Picture对象.
'*                该对象能赋给用户窗体中的图像(Image)控件
'*                PastePicture函数接受代表图片类型的可选参数 - xlBitmap or xlPicture.
'*
'*                代码需要引用"OLE Automation"类型库
'*
'*                代码来源于MSDN中发现的一些资料.
'*
'*                要使用这段代码,只需将该模块导入到您的工程中,然后使用:
'*                Set Image1.Picture = PastePicture(xlPicture)
'*                将剪贴板中的图片粘贴到标准的图像控件中.
'*
'* 过程:
'*   PastePicture   程序入口
'*   CreatePicture  私有函数来将bitmap或metafile句柄转换为OLE引用
'*   fnOLEError     为OLE错误代码获取错误文本
'***************************************************************************

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
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 过程: 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

下面将应用该通用模块提供的功能从剪贴板中提取图片,并将其放置到单元格批注中,最后从文件夹中删除该图片。注意,代码使用了CopyPicture方法将单元格区域复制为图片。
首先,声明公共变量:

Dim vFile As Variant

输入下列代码并运行,以获取图片:

Sub SaveAsPicture()
    Dim lPicType As Long, oPic As IPictureDisp
 
    '获取要保存图片的文件名称
    vFile = Application.GetSaveAsFilename(InitialFileName:="", _
               FileFilter:="BMP文件 (*.bmp), *.bmp")
    If vFile <> False Then
        '将单元格区域B2:C4复制为图片
        Sheet1.Range("B2:C4").CopyPicture
        Set oPic = PastePicture
        '将图片保存到文件中
        '如果剪贴板中没有图片则给出消息提示
        If Not oPic Is Nothing Then
            SavePicture oPic, vFile
        Else
            MsgBox "剪贴板中没有图片.", vbInformation, "粘贴图片 ..."
        End If
    Else
        MsgBox "没有指定文件名.", vbInformation, "粘贴图片 ..."
    End If
End Sub

输入下列代码并运行后,图片将被放到单元格批注中,然后删除文件夹中的图片:

Sub PutPictureInRangeComment()
    Dim rng As Range
    Set rng = Sheet1.Range("E2")
    On Error Resume Next
    rng.Comment.Delete
    On Error GoTo 0
    With rng.AddComment
        With .Shape
            .Height = 40
            .Width = 80
            .Fill.UserPicture vFile
        End With
        .Visible = True
    End With
    '删除图片文件
    Kill vFile
    '释放对象变量
    Set rng = Nothing
End Sub

运行后的结果如下图1所示:
ExportPictureFromExcel1
图1:将单元格区域图片放置到单元格批注中
示例文档下载:

示例2:将Excel单元格区域复制为图片,然后从剪贴板中取出该图片并放入用户窗体的图像控件中
本示例也可以使用上述ModPastePicture模块代码来完成,但这里另外提供了一段相似的代码。在VBE中插入一标准模块,并输入下面的代码:

Option Explicit
 
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
 
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
 
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc,  _
RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long,  _
ByVal lpszFile As String) As Long
Private 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
 
Function PictureFromObject(Target As Object) As IPictureDisp
    Dim hPtr As Long, PicType As Long, hCopy As Long
 
    Const CF_BITMAP = 2
    Const CF_PALETTE = 9
    Const CF_ENHMETAFILE = 14
    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    Const PICTYPE_BITMAP = 1
    Const PICTYPE_ENHMETAFILE = 4
    Target.CopyPicture
    PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, CF_BITMAP, CF_ENHMETAFILE)
    If IsClipboardFormatAvailable(PicType) <> 0 Then
        If OpenClipboard(0) > 0 Then
            hPtr = GetClipboardData(PicType)
            If PicType = CF_BITMAP Then
                hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Else
                hCopy = CopyEnhMetaFile(hPtr, vbNullString)
            End If
            CloseClipboard
            If hPtr <> 0 Then
                Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
 
                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
 
                With uPicInfo
                    .Size = Len(uPicInfo)
                    .Type = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
                    .hPic = hCopy
                End With
 
                OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
                Set PictureFromObject = IPic
            End If
        End If
    End If
End Function

然后,在VBE中插入用户窗体,在其中放置一个图像控件和一个按钮,并在用户窗体代码模块中输入下列代码:

Private Sub CommandButton1_Click()
    Dim rng As Range
    Set rng = Sheet1.Range("B2:C4")
    Set Image1.Picture = PictureFromObject(rng)
    Set rng = Nothing
End Sub

此时,运行用户窗体并单击按钮后如图2所示。
ExportPictureFromExcel2
图2:将单元格区域图片放置到用户窗体中
当然,也可以使用上述模块实现示例1的功能。例如,下面的代码将工作表中的图片输出到指定位置:

'将工作表中的图片输出到指定位置
Sub Example()
    '保存图像或形状
    SavePicture PictureFromObject(Sheet1.Pictures("Picture 1")), "C:\Picture 1.bmp"
    '保存形状
    SavePicture PictureFromObject(Sheet1.Shapes("WordArt 1")), "C:\WordArt 1.gif"
    '保存单元格区域
    SavePicture PictureFromObject(Sheet1.Range("B2:C4")), "C:\RangeB2_C4.jpg"
End Sub

示例文档下载:

一个实用加载宏
最后,提供AJP Excel Information中用于导出Excel图片的加载宏Graphics Exporter

相关文章