[[20170128150724]]　『Excel_VBAのForm1の現在位置取得（TopとLeft）』（マリオ）　ページの最後に飛ぶ

『Excel_VBAのForm1の現在位置取得（TopとLeft）』（マリオ）

 Excel_VBAで、ユーザーフォーム（Form1）の現在位置（TopとLeft）を取得したいです。ご教授願います。

 Visual Basic では、下記のAPIで動くらしいですが、
 Excel_VBAで、Form1のｺｰﾄﾞ記述欄に下記をコピペしてもダメでした。
 参考にしたサイト
http://www.petitmonte.com/visualbasic/vbapi_getwindowrect.html

 Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long

 Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
 End Type
 '----------------------------------------------------------------
 Private Sub Command1_Click()
    Dim nRect As RECT
    Call GetWindowRect(Form1.hWnd, nRect)
    MsgBox "左上のx座標は" & nRect.Left & vbCrLf & _
           "左上のy座標は" & nRect.Top & vbCrLf & _
           "右下のx座標は" & nRect.Right & vbCrLf & _
           "右下のy座標は" & nRect.Bottom
 End Sub

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

 確認です。

 ・Form1 や Command1 というオブジェクト名ですけど、そういう名前に変更しているのですね？
 ・Form1.hWnd　VBA では、このコードでハンドルは取得できません。
 　（このコード、VBA のコードではないようですね）
 ・ユーザーフォームのハンドルは
 　FindWindow("ThunderDFrame", Me.Caption)　もしくは　WindowFromAccessibleObject Me, hwnd　で取得します。
 ・もちろん、このGetWindowRectで取得する値はドキュメント座標ではなくピクセル値によるスクリーン座標です。
 　（先刻ご承知でしょうけど念のため）

（　β） 2017/01/28(土) 16:45

 おそらくやりたいことは以下？

 Private Sub CommandButton1_Click()
    Dim hwnd As Long
    Dim nRect As RECT

    WindowFromAccessibleObject Me, hwnd
    Call GetWindowRect(hwnd, nRect)
    MsgBox "左上のx座標は" & nRect.Left & vbCrLf & _
           "左上のy座標は" & nRect.Top & vbCrLf & _
           "右下のx座標は" & nRect.Right & vbCrLf & _
           "右下のy座標は" & nRect.Bottom
 End Sub

（　β） 2017/01/28(土) 16:49

 ↑　API宣言、念のため

  Private Declare Function WindowFromAccessibleObject Lib "oleacc" ( _
      ByVal pacc As Object, _
      ByRef phwnd As Long) As Long

 です。

（　β） 2017/01/28(土) 17:17

 >βさん
 おはようございます。
 CommandButton1_Clickで、座標を取得したので、今度は、
 次のように、UserForm_QueryCloseイベントで、
 Form1がUnloadする直前に、Top位置、Left位置を取得して、
 シート名「位置」のB1、B2セルに記録させるマクロを作成したのですが、

 次回起動時に、シート名「位置」のB1、B2セルの値を読み込んで、
 Form1を起動してるつもりが、
 終了させたときの位置と起動のときの位置が違うんです。
 これは、何ででしょうか？Winsows10(64bit),excel2013(32bit)環境です。

 >ドキュメント座標ではなくピクセル値によるスクリーン座標です。
 とありましたが、よく分かりません。
 対処法、ご教授願います。

 '■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
 '(1)シートの名前を「位置」にして、B1、B2セルそれぞれに「0」を入力
 '(2)UserRorm1、及びModule1をを作成
 -----------------------------------------------------------------
 '(3)ThisWorkbookのｺｰﾄﾞ欄に、次を記述
 Private Sub Workbook_Open()
    Call UserForm1表示
 End Sub
 -----------------------------------------------------------------
 '(4)Module1に次を記述
 Sub UserForm1表示()
    With UserForm1
        .Show vbModeless
        .Top = ThisWorkbook.Sheets("位置").Range("B1").Value
        .Left = ThisWorkbook.Sheets("位置").Range("B2").Value
    End With
 End Sub
 -----------------------------------------------------------------
 (5)UserForm1に次を記述
 Private Declare Function GetWindowRect Lib "USER32" ( _
      ByVal hwnd As Long, lpRect As RECT) As Long
 Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
 End Type
 Private Declare Function WindowFromAccessibleObject Lib "oleacc" ( _
      ByVal pacc As Object, _
      ByRef phwnd As Long) As Long

 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Dim hwnd As Long
    Dim nRect As RECT
    WindowFromAccessibleObject Me, hwnd 'ユーザーフォームのハンドルを取得
    Call GetWindowRect(hwnd, nRect)
   '*************************************************************
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("位置")
    sh.Range("B1").Value = CLng(nRect.Top) 'Top位置を書き込む
    sh.Range("B2").Value = CLng(nRect.Left) 'Left位置を書き込む
    Set sh = Nothing
   '*************************************************************
 End Sub
 Private Sub UserForm_Terminate()
    Application.DisplayAlerts = False
    If Workbooks.Count = 1 Then
       ThisWorkbook.Save: Application.Quit
    Else
       ThisWorkbook.Save: ThisWorkbook.Close
    End If
    Application.DisplayAlerts = True
 End Sub
 '----------------------------------------------------------------

（マリオ） 2017/01/29(日) 08:18

 コードは読んでいません。
 また、目的が、単に　ユーザーフォーム終了時点の位置を記憶させておいて、次回のユーザーフォーム表示では
 その位置に表示したいということであれば、難しいことは不要で、単純に QueryClose あたりで
 Me.Top と Me.Left の値を保存しておけばＯＫなんですが？

 もし、必要ならスクリーン座標とドキュメント座標の相違、ポイント値とピクセル値、ユーザーフォームにおける座標。
 そういったことについて、メモ的に書いてみてもいいですけど。
 （結構ややこしいですので、すっきりとメモできるかどうか心もとないですが）

 それとは別に、今回のテーマとは異なりますが、ユーザーフォームを指定のセル位置の場所に表示させたいという質問が
 ときどきアップされます。
 学校でも、何度か、回答したことがあるように記憶していますが、どのトピだったかわからなくなっています。
 たまたま最近、別板で（かつ別ＨＮですけど）回答したコードがあります。
 ご興味があればどうぞ。

http://www.moug.net/faq/viewtopic.php?t=75159&sid=ada62619f27949af2900dcfa77aa05ff

 なお、↑のトピで処理関連部品をまとめたモジュールをアップしていますが、これは、当方で、この種の処理時
 適宜、インポートして使っているもので、中には、トピで課題としているテーマには不要なものも混ざっています。
 そのあたりは、お含みおきください。

（β） 2017/01/29(日) 08:56

 追伸。

 コメントしたように、この目的なら、何も難しいことをする必要はありません。

 でも、あえて（？）難しくしたければ、取得したピクセル値をポイント値に変換してやればＯＫです。
 （繰り返します。そんなことをする必要は、全くありません）

 参考として、コードをアップしておきます。

 CommandButton1 を配置したユーザーフォームを表示し、ユーザーフォームの位置をいろいろ変えながら
 CommandButton1 をクリックしてみて下さい。

 Private Declare Function WindowFromAccessibleObject Lib "oleacc" ( _
      ByVal pacc As Object, _
      ByRef phwnd As Long) As Long
 Private Declare Function GetWindowRect Lib "USER32" (ByVal hwnd As Long, lpRect As RECT) As Long
 Private Declare Function GetDC Lib "User32.dll" (ByVal hwnd As Long) As Long
 Private Declare Function ReleaseDC Lib "User32.dll" (ByVal hwnd As Long, _
                                                   ByVal hdc As Long) As Long
 Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, _
                                                ByVal nIndex As Long) As Long

 Const LOGPIXELSX = 88
 Const LOGPIXELSY = 90

 Const PTUNIT As Single = 0.75  'エクセル上のポイント値は0.75の倍数

 Private Type Corners
     TopLeftX As Long
     TopLeftY As Long
     TopRightX As Long
     TopRightY As Long
     BottomLeftX As Long
     BottomLeftY As Long
     BottomRightX As Long
     BottomRightY As Long
 End Type

 Private Type WinXY
     x As Long
     y As Long
 End Type

 Private Type DocXY
     x As Double
     y As Double
 End Type

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

'600/300

 Private Sub CommandButton1_Click()
    Dim hwnd As Long
    Dim nRect As RECT

    WindowFromAccessibleObject Me, hwnd
    Call GetWindowRect(hwnd, nRect)
    MsgBox "左上のx座標は" & nRect.Left & vbCrLf & _
           "左上のy座標は" & nRect.Top & vbCrLf & _
           "右下のx座標は" & nRect.Right & vbCrLf & _
           "右下のy座標は" & nRect.Bottom

   MsgBox "上段がプロパティ値、下段はピクセル値からの換算です" & vbLf & _
            Me.Left & "/" & Me.Top & vbLf & _
            X_pix2point(nRect.Left) & "/" & Y_pix2point(nRect.Top)

 End Sub

Private Function X_pix2point(px As Long) As Double
'水平方向・ピクセルをポイントへ変換

    Dim PPI As Long
    Dim DPI As Long
    DPI = GetDPIX
    PPI = GetPPI
    X_pix2point = PTUNIT * Int((px * PPI / DPI) / PTUNIT)
End Function

Private Function Y_pix2point(px As Long) As Double

    Dim PPI As Long
    Dim DPI As Long
'水直方向・ピクセルをポイントへ変換
    DPI = GetDPIY
    PPI = GetPPI
    Y_pix2point = PTUNIT * Int((px * PPI / DPI) / PTUNIT)
End Function

Private Function GetPPI() As Long

    GetPPI = Application.InchesToPoints(1)
End Function

Private Function GetDPIX() As Long

    GetDPIX = GetDPI(LOGPIXELSX)
End Function

Private Function GetDPIY() As Long

    GetDPIY = GetDPI(LOGPIXELSY)
End Function

Private Function GetDPI(ByVal nFlag As Long) As Long

    Dim hdc As Long
    hdc = GetDC(Application.hwnd)
    GetDPI = GetDeviceCaps(hdc, nFlag)
    Call ReleaseDC(&H0, hdc)
End Function

（β） 2017/01/29(日) 09:01

 >βさん
 長々、申し訳ありません。ぺこり。
 >難しいことは不要で、単純に QueryClose あたりで
 >Me.Top と Me.Left の値を保存しておけばＯＫなんですが？
 あああああ、そうですね。Excel_VBAのForm、まだまだ不慣れなんで、
 気づかなかった（笑）QueryCloseイベントがあることを昨日知った
 レベルなんです。はい。すいませんでした。
（マリオ） 2017/01/29(日) 09:13

コメント返信：

[ 一覧(最新更新順) ]

[[20170128150724]] 『Excel_VBAのForm1の現在位置取得（TopとLeft）』（マリオ） ページの最後に飛ぶ

[[20170128150724]]　『Excel_VBAのForm1の現在位置取得（TopとLeft）』（マリオ）　ページの最後に飛ぶ