Excel VBA で画面より大きなフォームを表示する

'ユーザーフォームのモジュールに書く内容

    Option Explicit
       
    ' グローバル定数定義
    Const FullHD_W As Long = 1920
    Const FullHD_H As Long = 1080
    Const ZoomRatio As Long = 99
    Const UserForm1_Width As Long = 1440

'　フォームの初期化処理
Private Sub UserForm_Initialize()   
    
    Dim ScreenW, ScreenH As String
    Dim Rt, RtH, RtW As Double
      
    ' イメージ表示領域のサイズ設定
    ImageDisplayHeight = FrameDisplatImages.Height - 4
    ImageDisplayWidth = FrameDisplatImages.Width
    
    ' スクリーンサイズによる設定
    ScreenW = GetScreenX
    ScreenH = GetScreenY
    ' FullHD 未満の場合は画面の横幅に合わせてズームする
    If Val(ScreenW) < FullHD_W Or Val(ScreenH) < FullHD_H Then
        Me.Width = ActiveWindow.Width
        Me.Zoom = Round((Me.Width) / UserForm1_Width, 2) * ZoomRatio
    End If
    
End Sub


'標準モジュールに書く内容
Option Explicit

'*** Timer Function ***

Declare Function SetTimer Lib "user32" _
      (ByVal hwnd As Long, _
      ByVal nIDEvent As Long, _
      ByVal uElapse As Long, _
      ByVal lpTimerFunc As Long) As Long

Declare Function KillTimer Lib "user32" _
      (ByVal hwnd As Long, _
      ByVal nIDEvent As Long) As Long

Declare Function BeepAPI Lib "kernel32.dll" Alias "Beep" _
    (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long


Global iCounter As Integer


'*** Computer Infomation ***

'------------------------------------------
' ハードウェア
'------------------------------------------
     
' ユーザー名の長さを示す定数
Private Const UNLEN = 256 + 1
 
' NCBの名称の文字数
Private Const NCBNAMSZ = 16
 
' コンピュータ名の長さ
Private Const MAX_COMPUTERNAME_LENGTH = 15 + 1
 
' NCB(Network Control Block)コマンド
Private Const NCBRESET = &H32
Private Const NCBASTAT = &H33
     
' ローカルネットワーク名を格納する構造体
Private Type NAME_BUFFER
    name       As String * NCBNAMSZ
    name_num   As Byte
    name_flags As Byte
End Type
 
 
     
'さまざまなシステムメトリックの値（表示要素の幅と高さ）とシステムの現在の構成を取得
 
Private Const SM_CXSCREEN = 0       'スクリーン幅
Private Const SM_CYSCREEN = 1       'スクリーン高さ
Private Const SM_CMOUSEBUTTONS = 43 'マウスボタン数
Private Const SM_CMONITORS = 80     'モニター数
 
 
#If Win64 Then
 
    'システムの現在の構成を取得
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 
'    ' コンピュータ名を取得
'    Private Declare PtrSafe Function GetComputerName Lib "kernel32.dll" _
'        Alias "GetComputerNameA" _
'       (ByVal lpBuffer As String, _
'        nSize As Long) As Long
'
'    ' コンピュータ名を取得
'    Private Declare PtrSafe Function GetComputerNameEx Lib "kernel32.dll" _
'        Alias "GetComputerNameExA" _
'       (ByVal NameType As Long, _
'        ByVal lpBuffer As String, _
'        lpnSize As Long) As Long
 
     
    ' ユーザー名を取得
    Private Declare PtrSafe Function GetUserName Lib "advapi32.dll" _
        Alias "GetUserNameA" _
       (ByVal lpBuffer As String, _
        nSize As Long) As Long
     
 
 
#Else
 
    'システムの現在の構成を取得
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
     
'    ' コンピュータ名を取得
'    Private Declare Function GetComputerName Lib "kernel32.dll" _
'        Alias "GetComputerNameA" _
'       (ByVal lpBuffer As String, _
'        nSize As Long) As Long
'
'    ' コンピュータ名を取得
'    Private Declare Function GetComputerNameEx Lib "kernel32.dll" _
'        Alias "GetComputerNameExA" _
'       (ByVal NameType As Long, _
'        ByVal lpBuffer As String, _
'        lpnSize As Long) As Long
     
    ' ユーザー名を取得
    Private Declare Function GetUserName Lib "advapi32.dll" _
        Alias "GetUserNameA" _
       (ByVal lpBuffer As String, _
        nSize As Long) As Long
 
#End If
 
 
'------------------------------------------------------------------------
'
'Function ComputerName() As String
''
'' コンピュータ名
''
'    Dim strComputerNameBuffer _
'        As String * MAX_COMPUTERNAME_LENGTH
'    Dim lngComputerNameLength As Long
'    Dim lngResult             As Long
'
'    ' コンピュータ名の長さを設定
'    lngComputerNameLength = Len(strComputerNameBuffer)
'    ' コンピュータ名を取得
'    lngResult = GetComputerName(strComputerNameBuffer, lngComputerNameLength)
'    ' コンピュータ名を取り出し
'    ComputerName = Left(strComputerNameBuffer, InStr(strComputerNameBuffer, _
'                   vbNullChar) - 1)
'End Function
 
Function UserName() As String
'
' ログインユーザ名
'
    Dim strUserNameBuffer As String * UNLEN
    Dim lngUserNameLength As Long
    Dim lngResult         As Long
 
    ' ユーザー名の長さを設定
    lngUserNameLength = Len(strUserNameBuffer)
    ' ユーザー名を取得
    lngResult = GetUserName(strUserNameBuffer, lngUserNameLength)
    ' ユーザー名を表示
    UserName = Left(strUserNameBuffer, InStr(strUserNameBuffer, _
                   vbNullChar) - 1)
End Function
 
 
 
'Function MacAddress() As String
''
'' MAC アドレス
''   WMI を用いて MAC アドレスを取得
'
'    Dim strComputer As String   'コンピュータ名
'    Dim objWMI As Object        'WMIオブジェクト
'    Dim objAdapter As Object    'ネットワークアダプタ
'
'    ' 初期値
'    MacAddress = ""
'
'    Set objWMI = GetObject("winmgmts:\\.\root\cimv2").ExecQuery _
'        ("Select * From Win32_NetworkAdapterConfiguration " & _
'            "Where IPEnabled = True")
'
'    ' ネットワークアダプタ参照
'    For Each objAdapter In objWMI
'        'MACアドレス参照(最初に見つけたもので確定)
'        MacAddress = objAdapter.MacAddress
'        Exit Function
'    Next
'
'End Function
 
 
'Function GetIPAddress() As String
''
'' IP アドレス取得
''   WMI を用いて IP アドレスを取得
''
'    Dim NetAdapters, objNic, strIPAddress
'    Set NetAdapters = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2") _
'                           .ExecQuery("Select * from Win32_NetworkAdapterConfiguration " & _
'                           "Where (IPEnabled = TRUE)")
'     'ネットワークアダプターが複数ある場合、複数IPが割り当てられている場合は最初のみ取得
'    For Each objNic In NetAdapters
'        For Each strIPAddress In objNic.IPAddress
'            GetIPAddress = strIPAddress
'            Exit Function
'        Next
'    Next
'
'End Function
 
 
 
Function GetScreenX() As String
'
' スクリーンの幅
'
    GetScreenX = GetSystemMetrics(SM_CXSCREEN)
End Function


Function GetScreenY() As String
'
' スクリーンの高さ
'
    GetScreenY = GetSystemMetrics(SM_CYSCREEN)
End Function
'
'Function GetMonitorCount() As String
''
'' モニター数
''
'    GetMonitorCount = GetSystemMetrics(SM_CMONITORS)
'End Function
'
'Function GetMouseButtonCount() As String
''
'' マウスボタン数
''
'    GetMouseButtonCount = GetSystemMetrics(SM_CMOUSEBUTTONS)
'End Function