确定VBA中设备的类型

Question

我想用excel宏在平板电脑上锁定屏幕方向。有效。 但当我回到电脑前，它发给我了： “无法在user32中找到DLL入口点SetDisplayAutoRotationPreferences”。 用于锁定屏幕方向的代码如下：

Enum ORIENTATION_PREFERENCE
    ORIENTATION_PREFERENCE_NONE = 0
    ORIENTATION_PREFERENCE_LANDSCAPE = 1
    ORIENTATION_PREFERENCE_PORTRAIT = 2
    ORIENTATION_PREFERENCE_LANDSCAPE_FLIPPED = 4
    ORIENTATION_PREFERENCE_PORTRAIT_FLIPPED = 8
End Enum

Private Declare Function SetDisplayAutoRotationPreferences Lib "user32" (ByVal ORIENTATION_PREFERENCE As Long) As Long

Sub RotateToLandscape()
    Dim lngRet As Long
    lngRet = SetDisplayAutoRotationPreference (ORIENTATION_PREFERENCE_LANDSCAPE)
End Sub

它在计算机上不起作用的原因是因为Windows计算机上没有SetDisplayAutoRotationPreferences功能。

有没有办法确定运行宏的设备是否是平板电脑？或者也许是为了避免DLL入口点错误？ 计算机的操作系统是Windows 7，它使用excel 10'。

Answer 1

我怀疑，解决问题的最快方法是处理错误。

前言是以下示例，您现在将忽略SetDisplayAutoRotationPreference()函数引发的任何潜在错误。完全可以更加强大地处理以满足您的需求。有关进一步阅读，请参阅：http://www.cpearson.com/excel/errorhandling.htm

Sub RotateToLandscape()
    Dim lngRet As Long

On Error Resume Next 'When error occurs skip that line
    lngRet = SetDisplayAutoRotationPreference (ORIENTATION_PREFERENCE_LANDSCAPE)
On Error GoTo 0 'Set default error handling

End Sub

编辑：

在我目前的环境中，下面正确断言我正在使用桌面，但您可能需要在您的环境中进行测试。

Sub test_()
strComputerType = fGetChassis()
MsgBox "This Computer is a " & strComputerType
End Sub

Function fGetChassis()
    Dim objWMIService, colChassis, objChassis, strChassisType
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
    Set colChassis = objWMIService.ExecQuery("Select * from Win32_SystemEnclosure")
    For Each objChassis In colChassis
        For Each strChassisType In objChassis.ChassisTypes
            Select Case strChassisType
                Case 8
                    fGetChassis = "Laptop" '#Portable
                Case 9
                    fGetChassis = "Laptop" '#Laptop
                Case 10
                    fGetChassis = "Laptop" '#Notebook
                Case 11
                    fGetChassis = "Laptop" '#Hand Held
                Case 12
                    fGetChassis = "Laptop" '#Docking Station
                Case 14
                    fGetChassis = "Laptop" '#Sub Notebook
                Case 18
                    fGetChassis = "Laptop" '#Expansion Chassis
                Case 21
                    fGetChassis = "Laptop" '#Peripheral Chassis
                Case Else
                    fGetChassis = "Desktop"
            End Select
        Next
    Next
End Function

Answer 2

在我的搜索中，我也发现了以下链接：https://www.robvanderwoude.com/vbstech_inventory_laptop.php

以下代码以防超链接死亡：

If IsLaptop( "." ) Then
    WScript.Echo "Laptop"
Else
    WScript.Echo "Desktop or server"
End If


Function IsLaptop( myComputer )
' This Function checks if a computer has a battery pack.
' One can assume that a computer with a battery pack is a laptop.
'
' Argument:
' myComputer   [string] name of the computer to check,
'                       or "." for the local computer
' Return value:
' True if a battery is detected, otherwise False
'
' Written by Rob van der Woude
' http://www.robvanderwoude.com
    On Error Resume Next
    Set objWMIService = GetObject( "winmgmts://" & myComputer & "/root/cimv2" )
    Set colItems = objWMIService.ExecQuery( "Select * from Win32_Battery" )
    IsLaptop = False
    For Each objItem in colItems
        IsLaptop = True
    Next
    If Err Then Err.Clear
    On Error Goto 0
End Function