フォームを開いても真ん中に表示されない

質問

アクセス２００７です。
フォームのプロパティで「自動中央寄せ」を「はい」にして

Private Sub Form_Load()
DoCmd.RunCommand 10
DoCmd.ShowToolbar "Ribbon", acToolbarNo 'リボンを非表示にする
Application.CommandBars("Status Bar").Visible = False 'ステータスバーを非表示にする

'ナビゲーションウィンドウを表示しない
DoCmd.SelectObject acForm, "", True
DoCmd.RunCommand acCmdWindowHide
End Sub

をすると、真ん中に表示されません。

ナビゲーションウィンドウ分だけ左に寄ってしまいます。

Private Sub Form_Load()
'ナビゲーションウィンドウを表示しない
DoCmd.SelectObject acForm, "", True
DoCmd.RunCommand acCmdWindowHide

DoCmd.RunCommand 10
DoCmd.ShowToolbar "Ribbon", acToolbarNo 'リボンを非表示にする
Application.CommandBars("Status Bar").Visible = False 'ステータスバーを非表示にする
End Sub
のように順番を前後させても結果は同じです。

真ん中表示だけでなく、アプリケーションを最大化しつつ
リボン・ステータスバーを非表示に事は不可能でしょうか？

回答No.3

DexMachina · ベストアンサー

後出しすみません(汗)
手持ちのMDBファイルからコードのコピーだけして、そのまま回答し忘れていました(汗)

どの部分をどちらのサイトを参考にした、とかは忘れてしまっていますが(汗)、コメントで
残していたURLともども、ご紹介しておきます。

※WindowsAPI関数のスコープが「Public」になっていますが、TakeWindowCenter関数と
　同じモジュールに記述すれば「Private」でも問題ありません。
　(TakeWindowCenter関数だけはPublic必須)

'＝＝＝＝＝以下、当該フォーム＝＝＝＝＝

Private Sub Form_Load()
　　DoCmd.RunCommand acCmdAppMaximize
　　DoCmd.ShowToolbar "Ribbon", acToolbarNo
　　Application.CommandBars("Status Bar").Visible = False
　　DoCmd.SelectObject acForm, "", True
　　DoCmd.RunCommand acCmdWindowHide
　　Call TakeWindowCenter(Me.Form)
End Sub

'＝＝＝＝＝以下、標準モジュール＝＝＝＝＝

'http://www.ruriplus.com/msaccess/faq/faq_053.html
'http://www.moug.net/tech/acvba/0020033.htm
'http://msdn.microsoft.com/ja-jp/library/cc429812.aspx
'http://support.microsoft.com/kb/88922/ja
'http://delfusa.main.jp/delfusafloor/technic/technic/017_SystemMetrics.html
'http://support.microsoft.com/kb/210590/ja
'http://homepage1.nifty.com/rucio/main/Samples/vbsample016.htm

Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function MoveWindow Lib "user32" _
　　　　(ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, _
　　　　ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long

Private Const nTwipsPerInch = 1440, WU_LOGPIXELSX As Long = 88, WU_LOGPIXELSY As Long = 90

Public Function TakeWindowCenter(Frm As Form, Optional AdjustUpDown As Long = 0) As Boolean
On Error GoTo エラー処理

　　Dim Rsl As Boolean, MyX As Long, MyY As Long, MyW As Long, MyH As Long
　　Const PrcName As String = "TakeWindowCenter"
　　Const SM_CXSCREEN As Long = 0, SM_CYSCREEN As Long = 1

　　With Frm
　　　　MyW = ConvertTwipToPixels(.WindowWidth, False)
　　　　MyX = (GetSystemMetrics(SM_CXSCREEN) - MyW) / 2
　　　　MyH = ConvertTwipToPixels(.WindowHeight, True)
　　　　'高さは若干上にしたかったため、「2」ではなく「3」としています。
　　　　MyY = (GetSystemMetrics(SM_CYSCREEN) - MyH) / 3
　　　　'引数「AdjustUpDown」は上下位置の微妙な修正用です。
　　　　'(複数のポップアップフォームの同時展開時などに使用)
　　　　If AdjustUpDown Then MyY = MyY + ConvertTwipToPixels(AdjustUpDown, True)
　　　　Rsl = MoveWindow(.hWnd, MyX, MyY, MyW, MyH, True)
　　End With

終了処理:
　　TakeWindowCenter = Rsl
　　Exit Function
エラー処理:
　　Rsl = False
　　MsgBox Err.Number & "：" & Err.Description, vbCritical, PrcName
　　Resume 終了処理
End Function

Public Function ConvertTwipToPixels(lngTwips As Long, AsHeight As Boolean) As Long
On Error GoTo エラー処理

　　Dim Rsl As Long, lngDC As Long, lngPixelsPerInch As Long
　　Const PrcName As String = "ConvertTwipsToPixels"

　　lngDC = GetDC(0)
　　Select Case AsHeight
　　　　Case True: lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
　　　　Case Else: lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
　　End Select
　　lngDC = ReleaseDC(0, lngDC)
　　Rsl = (lngTwips * lngPixelsPerInch) / nTwipsPerInch

終了処理:
　　ConvertTwipToPixels = Rsl: Exit Function
エラー処理:
　　Rsl = 0
　　MsgBox Err.Number & "：" & Err.Description, vbCritical, PrcName
　　Resume 終了処理
End Function

お礼

ご回答ありがとうございました。

回答No.2

nicotinism

無理なのかどうかは不明です。
『私には判らなかった』という事です。ハイ。
もし、隣のマシンとかでも常に中央に・・という事でしたら
以前の回答が少しは役に立つかも？
http://okwave.jp/qa/q7887041.html
また、画面の解像度はこんなのでも求められます。
Sub y()
Dim wmi As Object
Dim monitorItems As Object, M As Object
Set wmi = GetObject("winmgmts:\\.\root\cimv2")
Set monitorItems = wmi.ExecQuery("Select * From Win32_DesktopMonitor")

For Each M In monitorItems
Debug.Print M.Name, "左右=" & M.ScreenWidth, "天地=" & M.ScreenHeight
Next
Set monitorItems = Nothing: Set wmi = Nothing
End Sub

追伸
少し手の込んだフォームを前回回答ので試したところ・・。
クイックアクセスツールバーとリボンのスペースだけが残り
その中には何も表示されていない状態。
肝心のフォームも行方不明。
になりもうした。orz
単純なフォームなら問題無さそう・・・です？
（ホントかな？？）
私からは以上です。

お礼

ご回答ありがとうございました。

回答No.1

nicotinism

これねえ、フォームが開かれる『前』の状態を基準にして
位置決めしてるっぽいです。
Access2000の頃にさんざん試しましたが惨敗 orz
面倒くさくなったので、見た目のセンターを適当に
Docmd movesize ・・・・
で済ませてしまっています。

Private Sub Form_open(cancel As Integer)
'ナビゲーションウィンドウを表示しない
DoCmd.SelectObject acForm, "", True
DoCmd.RunCommand acCmdWindowHide

DoCmd.RunCommand acCmdAppMaximize
DoCmd.ShowToolbar "Ribbon", acToolbarNo 'リボンを非表示にする
Application.CommandBars("Status Bar").Visible = False 'ステータスバーを非表示にする

DoCmd.SelectObject acForm, Me.Name
DoCmd.MoveSize 5000, 4000 '←ここを変更
End Sub

Private Sub Form_Unload(cancel As Integer)
'ナビゲーションウィンドウを表示する
DoCmd.SelectObject acForm, "", True

DoCmd.RunCommand acCmdAppRestore
DoCmd.ShowToolbar "Ribbon", acToolbarYes 'リボンを表示にする
Application.CommandBars("Status Bar").Visible = True 'ステータスバーを表示にする
End Sub

お礼

無理なのですかー
私と同じような事を試していたのですね。
MoveSizeでがんばって真ん中にします
ありがとうございました。