Access VBA Form の位置、サイズはtwip単位で係数は567である

まずコードでフォームを作ります

前提

新しいaccdbファイルを作り、モジュールを作って、以下のコードをコピーする。
そして、フォームが一つもない状態で
Sub Make_User_Form()
を起動し、フォーム1とテキストボックスが1つ作られ、
Sub searchForm()
を起動するとテキストボックスのサイズがイミディエイトに表示される

コード

Option Compare Database
Const twipTomm As Single = 56.7
Const twipToCm As Integer = 567
'10cmのテキストボックスを作って測ったもの
'------------------------------------------------------------
'https://qiita.com/Q11Q/items/a3c23012cf51872182ea
'ExcelのWorksheetFunction.RoundをVBAで実現する
'Static Function Log10(X) As Double
'Function xlRnd2(X, intflo As Integer)
'で構成されている
'別のモジュールに存在する場合は不要
'------------------------------------------------------------
Static Function Log10(X) As Double
Log10 = Log(X) / Log(10#)
End Function

Private Function xlRnd2(X, intflo As Integer)
Dim xDegit As Integer
' IsNumeric Check
If X * 0 <> 0 Then GoTo ERR_Hndl
On Error GoTo ERR_Hndl
If intflo < 0 Then
If CInt(Log10(Abs(X))) + 1 <= Abs(intflo) Then
xlRnd2 = X 'Error Return X value
Exit Function
Else
xlRnd2 = Int((Abs(X) * 10 ^ (intflo)) + 0.5) / (10 ^ intflo) * Sgn(X)
Exit Function
End If
Else
xlRnd2 = Int((Abs(X) * 10 ^ (intflo)) + 0.5) / (10 ^ intflo) * Sgn(X)
Exit Function
End If
Exit Function
ERR_Hndl:
xlRnd2 = 0
End Function
Sub Make_User_Form()
Const unitCoefficaintPer1000toCentimeter As Single = 1.764 '100単位当たり0.882cm縦横同じ
Dim intDataX As Integer, intDataY As Integer
Dim intLabelX As Integer, intLabelY As Integer
Dim ctlLabel As Control, ctlText As Control
Dim ojbForm As Access.Form
Dim fmCtrls As Controls, fmctrl As Control
'https://www.feedsoft.net/access/tips/tips79.html
'CreateFormを実行すると、デザインモードで最小化された状態で作成されます。
Set objform = Application.CreateForm
With objform
.Section(0).Height = 2000
.DividingLines = False
.Caption = "フォーム1"
.DividingLines = True
End With
Set fmctrl = Application.CreateControl(objform.Name, acTextBox, acDetail, , "test", 0, 0, 1133, Int(0.882 * tjpToCm))
DoCmd.Restore
'フォームの位置とサイズ
DoCmd.MoveSize Right:=1000, Down:=500, Width:=8000, Height:=3500
DoCmd.Close acForm, objform.Name, acSaveYes
End Sub
Sub searchForm()
'前のプロシージャで作ったフォームだけが存在するという前提で、フォームを開いて、コントロールの幅をイミディエイトに
'表示する
Dim cdb As dao.Database: Set cdb = CurrentDb
Dim frm As Form, frms As Forms
Dim acObj, aObj
Set acObj = CurrentProject.AllForms
For Each aObj In acObj
DoCmd.OpenForm aObj.Name, acDesign
Set frms = Application.Forms
Set frm = frms.Item(0)
'シンプルに値を表示
Debug.Print frm.Controls.Item(0).Width & "," & frm.Controls.Item(0).Height
'millimeterに換算、端数整理なし
Debug.Print (frm.Controls.Item(0).Width) / twipTomm & "mm," & (frm.Controls.Item(0).Height / twipTomm) & "mm"
'centimeterに換算、下3桁端数整理あり、概ねプロパティシートの表示に近づけている(プロパティシートは日本ではcmで表示する設定)
Debug.Print xlRnd2((frm.Controls.Item(0).Width) / 10 / twipTomm, 3) & "cm," & xlRnd2((frm.Controls.Item(0).Height / 10 / twipTomm), 3) & "cm"
Next aObj
End Sub

ここで問題

Right:=1000, Down:=500, Width:=8000, Height:=3500
このようにフォームやテキストボックスなどのコントロールの単位は何なのか。
10㎝にすると567くらいだ。
Access:twipとpixelとinchとcm 書いて忘れる

Accessで大きさを表す単位twipとpixel/inch/cmの関係。
1inch=1440twip
1inch=2.54cm
1cm=約567twip
1pixel=15twip ※1
ppi=pixel/inch
pixel=twip/ppi
※1 Windows画面は通常96ppiだが厳密には"GetDeviceCaps"APIで"LOGPIXELSY"を取得する必要がある。

Unit of Measure in Access

In VBA it is TWIPS (567 TWIPS per cm, 1440 TWIPS per inch). So I usually go like this

Const TW As Integer = 567
Me.something.Width = 3 * TW

Bob Larson, Access MVP 2008-2010, 2011

1440 twips が1インチ つまり12*12*10 = 2^5 * 3^2 *5
567 twips が1センチ 7 * 3^4
おそらく意図があるのだろうがcmだと奇数で分割が困難だ。3分割は計算しやすい。
インチだと両方に対応できる。

公式はPixcelばかり

ACC2000 Twip をピクセルに変換する方法

高度には、専門的なコーディング能力、相互運用性、およびマルチ ユーザーのスキルが必要です。
この資料には、Microsoft Access データベース (.mdb) と Microsoft Access プロジェクト (.adp) が適用されます。

翻訳

鬼ムズ
当然accdbにも通じるよ

概要

Access では、twip 単位と寸法と位置のプロパティが格納されて、特定の状況でする必要があります Windows API 関数を呼び出す場合など、ピクセルを twip 単位に変換します。この資料では、これを行う方法を示します。

翻訳

Acccessはオブジェクトの位置、縦横のSizeはtwip単位ですがAPIを使う時はPixlをtwipにするよ。(以下略)

詳細

Twip をピクセルに変換するのには、次の ConvertTwipsToPixels() 関数を使用できます。ピクセルは、常に正方形 (高さと幅が一致しません)。したがって、(水平方向または垂直方向) を使用する目的の [方向] で渡す必要があります。

翻訳

twipは縦横同じ長さだけどPixlは縦横同じじゃない。

コード

以下の３つは関数名の関係で定数名が変わっています

Const tjpTomm As Single = 56.7 'twip Per 1 mm
Const tjpToCm As Integer = 567 'twip Per 1 cm
Const tjpToInch As Integer = 1440 'twip Per 1 inch

また64bit 32bit共用化を図っています

コード

変換機能のあるマクロ

Option Compare Database
Const tjpTomm As Single = 56.7 'twip Per 1 mm
Const tjpToCm As Integer = 567 'twip Per 1 cm
Const tjpToInch As Integer = 1440 'twip Per 1 inch

Enum ScreenDirection
    HorizontalYoko
    VerticalTate
End Enum
'注: いくつかの Microsoft Windows API 関数を既存の Microsoft Access ライブラリで定義されている必要があります
'したがっての宣言には、重複があります。重複するプロシージャ名のエラー メッセージを受信する場合削除するか、
'コード内の宣言ステートメントをコメント アウトします。
#If VBA7 Then
Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
#Else
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
  ByVal hdc As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
  ByVal nIndex As Long) As Long
#End If

Const WU_LOGPIXELSX = 88
Const WU_LOGPIXELSY = 90
'------------------------------------------------------------
'https://qiita.com/Q11Q/items/a3c23012cf51872182ea
'ExcelのWorksheetFunction.RoundをVBAで実現する
'Static Function Log10(X) As Double
'Function xlRnd2(X, intflo As Integer)
'で構成されている
'別のモジュールに存在する場合は不要
'------------------------------------------------------------
Static Function Log10(X) As Double
Log10 = Log(X) / Log(10#)
End Function

Private Function xlRnd2(X, intflo As Integer)
Dim xDegit As Integer
' IsNumeric Check
If X * 0 <> 0 Then GoTo ERR_Hndl
On Error GoTo ERR_Hndl
If intflo < 0 Then
If CInt(Log10(Abs(X))) + 1 <= Abs(intflo) Then
xlRnd2 = X 'Error Return X value
Exit Function
Else
xlRnd2 = Int((Abs(X) * 10 ^ (intflo)) + 0.5) / (10 ^ intflo) * Sgn(X)
Exit Function
End If
Else
xlRnd2 = Int((Abs(X) * 10 ^ (intflo)) + 0.5) / (10 ^ intflo) * Sgn(X)
Exit Function
End If
Exit Function
ERR_Hndl:
xlRnd2 = 0
End Function


''''''''''''''''''''''''''''''''''''''''''''''''
'twip to Centimeters
''''''''''''''''''''''''''''''''''''''''''''''''
Function twipToCm(lgTwip As Long) As Single
'centimeterに換算、下3桁端数整理あり、
'概ねプロパティシートの表示に近づけている
'(プロパティシートは日本ではcmで表示する設定)
twipToCm = xlRnd2((lgTwip / tjpToCm), 3)
End Function
''''''''''''''''''''''''''''''''''''''''''''''''
'CentiMeter to twip
''''''''''''''''''''''''''''''''''''''''''''''''
Function CmTotwip(varCm As Variant) As Long
On Error Resume Next
CmTotwip = Int(CSng(varCm * tjpToCm))
If Err.Number <> 0 Then CmTotwip = 0: Err.Clear
End Function
''''''''''''''''''''''''''''''''''''''''''''''''
'twip to milliMeter
''''''''''''''''''''''''''''''''''''''''''''''''
Function twipToCm(lgTwip As Long) As Single
twipTomm = xlRnd2((lgTwip / tjpTomm), 3)
End Function
''''''''''''''''''''''''''''''''''''''''''''''''
'milliMeter to twip
''''''''''''''''''''''''''''''''''''''''''''''''
Function mmTotwip(varCm As Variant) As Long
On Error Resume Next
mmTotwip = Int(CSng(varCm * tjpTomm))
If Err.Number <> 0 Then mmTotwip = 0: Err.Clear
End Function
''''''''''''''''''''''''''''''''''''''''''''''''
'inches to twip
''''''''''''''''''''''''''''''''''''''''''''''''
Function InchesTotwip(varInch As Variant) As Long
On Error Resume Next
InchesTotwip = Int(CSng(varInch * tjpTomm))
If Err.Number <> 0 Then InchesTotwip = 0: Err.Clear
End Function

'''http://blogwizhook.blog.fc2.com/blog-entry-143.html

Function ConvertTwipsToPixels(lngTwips As Long, _
   lngDirection As Long) As Long

   'Handle to device
   Dim lngDC As Long
   Dim lngPixelsPerInch As Long
   Const nTwipsPerInch = 1440
   lngDC = GetDC(0)

   If (lngDirection = 0) Then       'Horizontal
      lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
   Else                            'Vertical
      lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
   End If
   lngDC = ReleaseDC(0, lngDC)
   ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch

End Function

'------------------------------------------------------------------------
'この関数を呼び出すには、数に変換する twip 単位と水平方向または垂直方向の測定値を示す
'別のパラメーターを渡す (横方向、0 以外の場合は 0 の垂直方向)。サンプルの呼び出しは、
'次のようにします。
'-------------------------------------------------------------------------
Function ShowConvert()
   Dim lngOldTwips As Long
   lngOldTwips = 2377
   ShowConvert = ConvertTwipsToPixels(lngOldTwips, 0)
End Function

'http://blogwizhook.blog.fc2.com/blog-entry-143.html

クラスモジュールにGetSystemMatrixを

'----------------------------
' Display Class Module
'----------------------------
'このScriptはVBAのクラスモジュール用です
' 標準モジュールでは動きません
' 64/32 共用です
' Classモジュールの名前をVBEにおいてF4を押しプロパティウィンドウを出し、(オブジェクト名)に半角で
' DisplaySizeClass
' と入力してください
' GetsystemMetrixとは...
'"たとえば、GetSystemMetrics 関数は、オペレーティング システムの異なる機能を指定する 75 個の定数のいずれかを取得します。
'関数により返される情報は、渡した定数により異なります。GetSystemMetrics を呼び出すには、75 個のすべての定数ではなく、使用する定数のみを含めます。
'メモ   定数を表す値を渡すよりも、定数を定義する方法をお勧めします。定数は Microsoft 製品がバージョンアップしても変わりませんが、定数値は変更する可能性があります。
'DLL 関数に必要な定数は一般的に予測不可能なものが多いので､特定の値を返すためには､目的の関数のドキュメントを参照して､渡す定数を確認する必要があります｡

#If VBA7 Then
Private Declare PtrSafe Function GetSystemMetrics _
Lib "USER32" _
(ByVal nIndex As Long) As Long
#Else
Private Declare Function GetSystemMetrics Lib "USER32" (ByVal nIndex As Long) As Long
#End If
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1

'アクセサ
'取得 Property Get ClassではFunctionの役割をする
Property Get GetDisplaySizeXPixels() As Long
GetDisplaySizeXPixels = GetSystemMetrics(SM_CXSCREEN)
End Property
Property Get GetDisplaySizeYPixels() As Long
GetDisplaySizeYPixels = GetSystemMetrics(SM_CYSCREEN)
End Property

'Sub DisplaySizeClassUsingStandardModle()
''https://www.moug.net/tech/acvba/0020033.html
''ここのサンプルからClassモジュールを作成し書き換えました
''この Sub Procedure(サブプロシージャ)は標準モジュール用のコードです
'Dim c As DisplaySizeClass
'Set c = New DisplaySizeClass
'Debug.Print c.GetDisplaySizeXPixels, c.GetDisplaySizeYPixels
'End Sub