[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セルに合わせてUserFormを表示する手法のZoom対応について』（白茶）
すみません、ちょっとした質問です。
ネット上でよく見かける手法(だと思ってるのですが)で、
「(対象セルのTop/Left * DPI / PPI) * Window.Zoom / 100」に 「PointsToScreenPixels(0)で得た座標」を足してピクセル単位の座標を算出し、 それをまた * PPI / DPIしてポイント単位に変換
ていうのがありますよね? あれって、Windowの表示倍率100%以外の時にちゃんと機能します? 概ね近い場所に表示されるのなら問題ないのですが、 とんでもない結果になるパターンの方が多い気がするのですが・・・
ちょっと別の手法を検証してみようとも思っているのですが、 その前に、上記の手法で変になるのは自分のコードだけなのでは? と不安で。
上記手法は、例えば 新規シートで表示倍率を70%にしてCC65000セルを基点にフォームを表示させる なんていうパターンにも概ね対応できるものなのでしょうか? それとも変になるものなのでしょうか?
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
回答ではありません。
少なくとも私の持っているコードでは、75%を下回るにつれ、少しずつ、ぴったりかんかん とはいかなくなりますね。 100%であっても、計算結果のピクセル値は正しい（そこを SetCursorPos でポイントさせるとぴったり）のですが さらにポイント値に変換して、かつ、それをユーザーフォームのTOP/LEFT として与えた場合、若干ずれます。
(学校の別トピでマリオさんから指摘されてもいます）
ただ 『とんでもない結果になるパターンの方が多い気がするのですが・』ということではなく おおむね、そのあたりには配置されますけど・・・
なかなか、追及する気力がわかず、そのままにしてありますが、本トピに対してエキスパートさんたちからの ずばりの回答が寄せられることを期待してROMします。
（β） 2017/03/23(木) 23:45
βさん、???さん、お返事ありがとうございます。
>おおむね、そのあたりには配置されますけど・・・ あら。そうなのですか 私もピッタリとまでは目指してないので、 誤差範囲が標準サイズのセル2〜3個分以内なら、まあいいかと思ってます。
>>新規シートで表示倍率を70%にしてCC65000セルを基点にフォームを表示させる というのは >>とんでもない結果になるパターン を再現できる様に示した極端な例なのですが、
例えばこちら http://www.h3.dion.ne.jp/~sakatsu/Excel_Tips22.htm で紹介されている手法を参考に
Sub test_kt() Const DPI As Long = 96 Const PPI As Long = 72
Dim pxTop As Long Dim pxLeft As Long
With ActiveWindow pxTop = ((ActiveCell.Top * (DPI / PPI)) * (.Zoom / 100)) pxLeft = ((ActiveCell.Left * (DPI / PPI)) * (.Zoom / 100)) Debug.Print "セル位置", pxTop, pxLeft Debug.Print "R1C1座標", .Panes(1).PointsToScreenPixelsY(0), .Panes(1).PointsToScreenPixelsX(0)
pxTop = pxTop + .Panes(1).PointsToScreenPixelsY(0) pxLeft = pxLeft + .Panes(1).PointsToScreenPixelsX(0) Debug.Print "セル座標", pxTop, pxLeft End With End Sub
とりあえずピクセル単位の結果を確認するものですが、 これを DPIやStandardFontの設定変更をやってない環境下で 新規シート(分割・枠固定も無し、ActiveWindowは最大化の状態)で、 ActiveCellがVisibleRangeの先頭に来る様にスクロールした状態で実行します。
Zoomが85%の場合 A1セルで セル位置 0 0 R1C1座標 114 26 セル座標 114 26 A500セルで セル位置 7635 0 R1C1座標 -7371 26 セル座標 264 26 ちょっと誤差がありすぎると思います。 ちなみに CC65000セルだと セル位置 994485 4896 R1C1座標 -974871 -4840 セル座標 19614 56 ディスプレイの遥か下です。
Zoomを70%にした場合なら A500セルでは セル位置 6287 0 R1C1座標 -6374 23 セル座標 -87 23 CC65000セルだと セル位置 818987 4032 R1C1座標 -844874 -3965 セル座標 -25887 67
今度はディスプレイの遥か上です。
これは「そういうもの」なのかなぁ? それとも自分の環境だけなのかなぁ? と思ったのです。
いま少しずつ検証を始めている手法だと、何となく許容範囲の誤差に落ち着きそうな感じなのですが、 自分の環境だけおかしいのなら、それも無駄になりそうで・・・
上記の結果は「そういうもの」でしょうか?
（白茶） 2017/03/24(金) 13:52
参照された角田さんのサイトで紹介されているコードと、私が試行錯誤して たどりついたコードは、ほぼ、同じ手法をとっています。
このあたりについては、
http://www.excel.studio-kazu.jp/kw/20170302214231.html
http://www.excel.studio-kazu.jp/kw/20170128150724.html
で、マリオさんと、掛け合い漫才のようなディスカッションをしています。 そこでも提示しているんですが、私のコードは
http://www.moug.net/faq/viewtopic.php?t=75159&sid=ada62619f27949af2900dcfa77aa05ff
ここにもアップしてあります。
それはさておき、提示されたコード、必ずしも角田さんのものを忠実に反映していないのでは？
まず、Point値は整数ではなく Single (私のコードではDoubleにしていますが）、つまり小数点以下ありですよね。 なんとなく、計算の順序が少し変かな？と思います。（詳細にはチェックしていませんが）
そちらのコードの、セル位置 や セル座標 といったもので、何をあらわそうとしておられるのか まだ、熟読していませんが、提示の状態（CC65000をVisibleRangeの左上隅とする状態）↑でふれた、私のコードを用いて実行すると、 CC65000 の ポイント値やピクセル値の値は、正常なものになります。
念のためコードを以下にはっておきます。 （いわずもがなですけど、ユーザーフォームに与えるTopやLeftは『スクリーン座標』としてのポイント値です）
●テストプロシジャ
Sub Test()
Dim myPix As Corners
Dim rtn As Long
Dim Target As Range
Set Target = ActiveCell
myPix = GetWinPosOfObject(Target) 'Point値からPixcel値への変換
Debug.Print "セル位置(ドキュメント座標) ", Target.Top, Target.Left
Debug.Print "セル位置(スクリーン座標-ピクセル変換) ", myPix.TopLeftY, myPix.TopLeftX
Debug.Print "セル位置(スクリーン座標-ピクセルからポイント変換)", Y_pix2point(myPix.TopLeftY), X_pix2point(myPix.TopLeftX)
End Sub
●共通モジュール（こちらの共通モジュールなので本件処理には不要なものもありますが、フルセット）
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の倍数
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
Type WinXY
x As Long
y As Long
End Type
Type DocXY
x As Double
y As Double
End Type
Function GetWinPosOfObject(Target As Object) As Corners
'指定されたセルまたは図の四隅のウィンドウ座標を取得
Dim pn As Pane
Dim wkX As WinXY
Dim wkP As DocXY
Dim obj As Object
Set obj = Target
If TypeName(obj) <> "Range" Then Set obj = Target.TopLeftCell
Set pn = GetPane(obj) '属するPane
With Target
'左上隅
wkP.x = .Left
wkP.y = .Top
wkX = GetWinPosByPoint(pn, wkP)
GetWinPosOfObject.TopLeftX = wkX.x
GetWinPosOfObject.TopLeftY = wkX.y
'右上隅
wkP.x = .Left + .Width
wkP.y = .Top
wkX = GetWinPosByPoint(pn, wkP)
GetWinPosOfObject.TopRightX = wkX.x
GetWinPosOfObject.TopRightY = wkX.y
'左下隅
wkP.x = .Left
wkP.y = .Top + .Height
wkX = GetWinPosByPoint(pn, wkP)
GetWinPosOfObject.BottomLeftX = wkX.x
GetWinPosOfObject.BottomLeftY = wkX.y
'右下隅
wkP.x = .Left + .Width
wkP.y = .Top + .Height
wkX = GetWinPosByPoint(pn, wkP)
GetWinPosOfObject.BottomRightX = wkX.x
GetWinPosOfObject.BottomRightY = wkX.y
End With
End Function
Function GetWinPosByPoint(pn As Pane, pt As DocXY) As WinXY
'ドキュメント座標ポイント値からウィンドウ座標のピクセル値を取得
GetWinPosByPoint.x = pn.PointsToScreenPixelsX(0) + X_point2pix(pt.x) * ActiveWindow.Zoom / 100
GetWinPosByPoint.y = pn.PointsToScreenPixelsY(0) + Y_point2pix(pt.y) * ActiveWindow.Zoom / 100
End Function
Function GetPane(Target As Range) As Pane
'指定されたセルが属するPaneを取得
'取得したPaneオブジェクト.Index で区画判別ができる。
Dim sRow As Long
Dim sCol As Long
Dim idx As Long
Dim wn As Window
Set wn = Windows(Target.Parent.Parent.Name)
sRow = wn.SplitRow
sCol = wn.SplitColumn
If sCol = 0 Then sCol = Columns.Count + 1
If sRow = 0 Then sRow = Rows.Count + 1
Select Case True
Case Target.Row <= sRow And Target.Column <= sCol
idx = 1
Case Target.Row <= sRow And Target.Column > sCol
idx = 2
Case Target.Row > sRow And Target.Column > sCol
idx = 4
Case Else
If wn.Panes.Count = 4 Then
idx = 3
Else
idx = 2
End If
End Select
Set GetPane = wn.Panes(idx)
End Function
Function X_point2pix(pt As Double) As Long
'水平方向・ポイントをピクセルへ変換
Dim PPI As Long
Dim DPI As Long
DPI = GetDPIX
PPI = GetPPI
X_point2pix = Int(pt * DPI / PPI)
End Function
Function Y_point2pix(pt As Double) As Long
'水直方向・ポイントをピクセルへ変換
Dim PPI As Long
Dim DPI As Long
DPI = GetDPIY
PPI = GetPPI
Y_point2pix = Int(pt * DPI / PPI)
End Function
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
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
Function GetPPI() As Long
GetPPI = Application.InchesToPoints(1)
End Function
Function GetDPIX() As Long
GetDPIX = GetDPI(LOGPIXELSX)
End Function
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/03/24(金) 17:37
前言撤回です！
100%であれば CC65000 であっても、ほぼほぼＯＫですが、80% にすると 角田さんのコードでも 私のコードでも、おっしゃるとおり、ディスプレイのはるか上になってしまいますね。
これは、難問ですねぇ。
（β） 2017/03/24(金) 18:31
なんでそんなとこに表示しなければならないんでしょう？
明確な納得できる理由があれば、試す価値ありそうですが、、、、
深く追及する意味があるのかないのか。。。
所詮表計算ソフトなので表示や印刷は不得意かと。
（まっつわん） 2017/03/24(金) 18:42
βさん、ありがとうございます。 わざわざコードまで紹介して頂いて・・・。恐れ入ります。
拝見しましたコードですが、現在検証中の私のものと構成というか骨子?外観?が似ていて 驚きと同時に、嬉しさというか安心感というか、何だかニヤニヤしてしまいました。 (まぁ、やろうとしてる事が同じなんだから当然と言えば当然ですね)
>角田さんのコードでも私のコードでも、おっしゃるとおり、ディスプレイのはるか上になってしまいますね。 お! そうですか! とりあえず検証中のものは続行しても良さそうです。 もー「誤差でるよ」って記事と全然遭遇しないからめっちゃ不安でしたよ。
まっつわんさん、お返事ありがとうございます。 >なんでそんなとこに表示しなければならないんでしょう？ はい。勿論、自己満足です >明確な納得できる理由 ないですね。 >深く追及する意味があるのかないのか いやー、ないない と言うか、別に「深く」は追求してないんですよ。 実務で >CC65000セルを基点にフォームを表示させる 事は、まぁ滅多にないんですが、 5千行〜3万行くらいまでのデータは日常的に相手にしているんですね。
で、とある汎用目的のちっちゃいUserFormをひとつふたつ表示させることがしばしばあるのですが、 そいつの用途の性質上、ActiveCell付近(ピッタリである必要は無い)に出現させると 感覚的にたいへん仕事がやり易いんですよ。
で、そうしようと思っても変な所に出てきたりするので「何とかできないかなぁ」と思ってるだけなのです。 3千行目くらいでも(対策打ってなかったら)画面から居なくなっちゃいますからね。 あと、標準スタイルが自分の環境と違うところから貰ったファイルなんかでも妙なズレが出やすいでしょうか。
いま検証しているものの方向性なのですが、 ((標本セルのHeight/Width * DPI / PPI) * Window.Zoom / 100) ÷ (標本セルのHeight/Width * DPI / PPI) で垂直・水平それぞれの実縮尺比を出して、 (対象セルのTop/Left * DPI / PPI) * 実縮尺比 という風にする考え方です。 で、 この「標本セル」として適当なのは何だろうか? という所で試行錯誤中です。
最初は「標本セル = 対象セル」で良いかと思ったのですが、 対象セルが例外的なサイズだったら実縮尺比が不適当になるので危険。
StandardHeight/StandardWidthを基準にしようともしましたが、 これらの値がゼロのシートもあり得るので却下。
そもそもStandardWidthからWidthを求めるには、 標本としてStandardWidthと同幅のセルがひとつは必要になります。 StandardWidthと同幅のセルが存在しないシートがあり得るという点でも却下。
直近の案がVisibleRangeを標本にする手法です。 R1C1から対象セル迄の範囲でRowHeight/ColumnWidthの戻り値がNullとなる様なシートじゃなければ、 かなり近い場所には表示出来てます。 しかし実務ではむしろ、そういう状態(特に列幅)のシートが大半な訳ですから、 どうしても変な誤差が出てしまいます。
後で現状コードをそのまま貼っておきます。 別のアプローチ案とか、何か糸口的なものでも出てくればいいな。と思いつつ・・・
ちなみに、このスレ立てる前に「次はどうしようか」と考えてたのが、 「そもそもは PointsToScreenPixels(0) + VisibleRange左上から対象セルまでの距離 で良いハズなんだよね 」
という事です。 Windowの分割や枠固定とか、対象セルがVisibleRange内に無かったりとか いろいろ対策が必要ではあるでしょうけど。
とりあえず、今回はお付き合い頂きありがとうございました。
しばらくの間は引き続きレス確認しに来ますので、 何かありましたら言ってやって下さい。
（白茶） 2017/03/24(金) 21:28
現状コードです。検証用の邪魔な部分は削ったつもり・・・ですが、消し忘れかあるやも知れません。
Rem 標準モジュール _/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/ Option Explicit Private Type apiCursorPos x As Long y As Long End Type Public Type apiRECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Const SPI_GETWORKAREA = 48 Private Const LOGPIXELSX As Long = 88 Private Const LOGPIXELSY As Long = 90
Private Declare Function GetCursorPos Lib "user32" (lpPoint As apiCursorPos) 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 Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _ ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Rem ========================================================================================================= Public Property Get xDPI() As Long '水平DPI xDPI = GetDPI(LOGPIXELSX) End Property Public Property Get yDPI() As Long '垂直DPI yDPI = GetDPI(LOGPIXELSY) End Property Public Property Get xlPPI() As Long 'エクセルPPI xlPPI = Application.InchesToPoints(1) End Property
Rem ========================================================================================================= Rem マウスカーソル座標でフォーム表示する為のTopとLeftを得る(画面からのはみ出し補正付き)■今回の話題とは無関係 Rem 引数 LimitToEdge --- 画面の右または下にフォームがはみ出そうな場合の基点座標の補正方法を切り替える Rem True ------------- はみ出る幅及び高さ分だけ左上方向に減算する(画面端にくっ付く感じでフォームを表示) Rem False(規定値) ---- フォームの幅及び高さ分左上方向に減算する(フォームの表示方向が逆転する) Public Sub GetTopLeftFromMouseCur(ByRef fTop As Single, ByRef fLeft As Single, _ ByVal fHeight As Single, ByVal fWidth As Single, _ Optional ByVal LimitToEdge As Boolean = False _ ) Dim cPos As apiCursorPos, MyTop As Single, MyLeft As Single Dim aRect As apiRECT, LmtTop As Single, LmtLeft As Single Rem ディスプレイサイズ(ピクセル単位)取得 Call SystemParametersInfo(SPI_GETWORKAREA, &H0, aRect, &H0) Rem カーソル座標(ピクセル単位)取得 Call GetCursorPos(cPos) Rem 垂直方向の開始位置補正計算 MyTop = Px2PtY(cPos.y) 'マウス座標をポイントに変換 If MyTop < 0 Then MyTop = 0 LmtTop = Px2PtY(aRect.Bottom) - fHeight 'フォームが画面からはみ出さない開始位置の上限を算出 If LmtTop < 0 Then LmtTop = 0 '(画面よりフォームがデカい場合は開始位置の上限はゼロ) If MyTop > LmtTop Then 'マウス座標が開始位置の上限を超えていた場合は補正する If MyTop > fHeight Then '├─マウス座標までの範囲にフォームが収まる様なら MyTop = MyTop - fHeight '｜ └─開始位置は「マウス座標 - フォームのデカさ」 If LimitToEdge Then MyTop = LmtTop Else '└─フォームが収まらないなら、どのみちはみ出ちゃうから MyTop = LmtTop ' └─開始位置は「開始位置の上限」とする End If End If Rem 水平方向の開始位置補正計算 MyLeft = Px2PtX(cPos.x) If MyLeft < 0 Then MyLeft = 0 LmtLeft = Px2PtX(aRect.Right) - fWidth If LmtLeft < 0 Then LmtLeft = 0 If MyLeft > LmtLeft Then If MyLeft > fWidth Then MyLeft = MyLeft - fWidth If LimitToEdge Then MyLeft = LmtLeft Else MyLeft = LmtLeft End If End If Rem 計算結果を返して終わる fTop = MyTop fLeft = MyLeft End Sub Rem ========================================================================================================= Rem セル座標でフォーム表示する為のTopとLeftを得る(画面からのはみ出し補正付き) Rem 引数 LimitToEdge --- 画面の右または下にフォームがはみ出そうな場合の基点座標の補正方法を切り替える Rem True ------------- はみ出る幅及び高さ分だけ左上方向に減算する(画面端にくっ付く感じでフォームを表示) Rem False(規定値) ---- フォームの幅及び高さ分左上方向に減算する(フォームの表示方向が逆転する) Public Sub GetTopLeftFromCellBR(ByVal aCell As Range, ByRef fTop As Single, ByRef fLeft As Single, _ ByVal fHeight As Single, ByVal fWidth As Single, _ Optional ByVal LimitToEdge As Boolean = False _ ) Dim MyTop As Single, MyLeft As Single Dim aRect As apiRECT, LmtTop As Single, LmtLeft As Single Dim cRect As apiRECT Rem ディスプレイサイズ(ピクセル単位)取得 Call SystemParametersInfo(SPI_GETWORKAREA, &H0, aRect, &H0) Rem セルのピクセル座標取得 cRect = GetCellRect(aCell) Rem 垂直方向の開始位置補正計算 MyTop = Px2PtY(cRect.Bottom) If MyTop < 0 Then MyTop = 0 'セル下部が画面より上だったら画面上端 If cRect.Bottom > aRect.Bottom Then MyTop = Px2PtY(cRect.Top) 'セル下部が画面より下だったらセル上部 If cRect.Top > aRect.Bottom Then MyTop = Px2PtY(aRect.Bottom) 'セル上部も画面より下だったら画面下端 LmtTop = Px2PtY(aRect.Bottom) - fHeight If LmtTop < 0 Then LmtTop = 0 If MyTop > LmtTop Then If MyTop > fHeight Then MyTop = MyTop - fHeight If LimitToEdge Then MyTop = LmtTop Else MyTop = LmtTop End If End If Rem 水平方向の開始位置補正計算 MyLeft = Px2PtX(cRect.Right) If MyLeft < 0 Then MyLeft = 0 'セル左部が画面より左だったら画面左端 If cRect.Right > aRect.Right Then MyLeft = Px2PtX(cRect.Left) 'セル右部が画面より右だったらセル左部 If cRect.Left > aRect.Right Then MyLeft = Px2PtX(aRect.Right) 'セル左部も画面より右だったら画面右端 LmtLeft = Px2PtX(aRect.Right) - fWidth If LmtLeft < 0 Then LmtLeft = 0 If MyLeft > LmtLeft Then If MyLeft > fWidth Then MyLeft = MyLeft - fWidth If LimitToEdge Then MyLeft = LmtLeft Else MyLeft = LmtLeft End If End If Rem 計算結果を返して終わる fTop = MyTop fLeft = MyLeft End Sub
Rem ========================================================================================================= Rem ピクセル⇔ポイント変換 Public Function Px2PtX(aPixel As Long) As Single 'ピクセルを水平ポイントに変換 Px2PtX = Int((aPixel * xlPPI / xDPI) / (xlPPI / xDPI)) * (xlPPI / xDPI) 'Int((px * 0.75) / 0.75) * 0.75 End Function Public Function Pt2PxX(aPoint As Single) As Long '水平ポイントをピクセルに変換 Pt2PxX = Int(aPoint * xDPI / xlPPI) End Function Public Function Px2PtY(aPixel As Long) As Single 'ピクセルを垂直ポイントに変換 Px2PtY = Int((aPixel * xlPPI / yDPI) / (xlPPI / yDPI)) * (xlPPI / yDPI) End Function Public Function Pt2PxY(aPoint As Single) As Long '垂直ポイントをピクセルに変換 Pt2PxY = Int(aPoint * yDPI / xlPPI) End Function
Rem ========================================================================================================= Rem セルの属するウィンドウのピクセル座標取得 Public Function GetWinLeft(aCell As Range) As Long GetWinLeft = GetPaneFromCell(aCell).PointsToScreenPixelsX(0) End Function Public Function GetWinTop(aCell As Range) As Long GetWinTop = GetPaneFromCell(aCell).PointsToScreenPixelsY(0) End Function
Rem ========================================================================================================= Rem セルのピクセル座標取得 Public Function GetCellRect(aCell As Range) As apiRECT Dim wZm As Long, px As Long, zmY As Single, zmX As Single With GetPaneFromCell(aCell) wZm = .Parent.Zoom zmY = PixZoomY(wZm, .VisibleRange) zmX = PixZoomX(wZm, .VisibleRange) px = Pt2PxY(aCell.Top) * zmY GetCellRect.Top = px + .PointsToScreenPixelsY(0) px = Pt2PxX(aCell.Left) * zmX GetCellRect.Left = px + .PointsToScreenPixelsX(0) px = Pt2PxY(aCell.Top + aCell.Height) * zmY GetCellRect.Bottom = px + .PointsToScreenPixelsY(0) px = Pt2PxX(aCell.Left + aCell.Width) * zmX GetCellRect.Right = px + .PointsToScreenPixelsX(0) End With End Function
Rem ========================================================================================================= Rem 以下、内部処理 Private Function GetDPI(nIndex As Long) As Long 'DPI取得 Dim hdc As Long hdc = GetDC(Application.hWnd) GetDPI = GetDeviceCaps(hdc, nIndex) ReleaseDC &H0, hdc End Function Rem セルの属するPaneオブジェクトを取得 Private Function GetPaneFromCell(aCell As Range) As Pane Dim pnId As Long With aCell.Worksheet.Parent.Windows(1) If .FreezePanes Then 'ウィンドウ枠が固定されてたら Select Case .Panes.Count Case 2 pnId = 1 If .SplitRow = 0 Then If aCell.Column > .SplitColumn Then pnId = pnId + 1 Else If aCell.Row > .SplitRow Then pnId = pnId + 1 End If Case 4 pnId = 1 If aCell.Column > .SplitColumn Then pnId = pnId + 1 If aCell.Row > .SplitRow Then pnId = pnId + 2 Case Else '←ありえへん訳だが一応・・・ pnId = 1 End Select Set GetPaneFromCell = .Panes(pnId) Else 'ウィンドウ枠が固定されてなかったら Set GetPaneFromCell = .ActivePane 'とりあえず素直にActivePaneを使う事にしておこう End If End With End Function
Rem ズーム値からピクセル上の実縮尺比を算出 Function PixZoomX(WinZoom As Long, aCols As Range) As Single Dim px1 As Long, pxN As Long Dim Ra As Range, c As Long For Each Ra In aCols.Columns '■現行案:見えてる範囲の平均列幅を採用 If Not Ra.Hidden Then c = c + 1 Next px1 = Pt2PxX(aCols.Width / c) pxN = WorksheetFunction.Round(px1 * WinZoom / 100, 0) '銀行丸め回避 PixZoomX = pxN / px1 ' Debug.Print "X" & WinZoom, pxN & "/" & px1, PixZoomX, aCols.Address(0, 0), c End Function Function PixZoomY(WinZoom As Long, aRows As Range) As Single Dim px1 As Long, pxN As Long, r As Range Dim Ra As Range, c As Long For Each Ra In aRows.Rows '■現行案:見えてる範囲の平均行高を採用(平均でいいのか?) If Not Ra.Hidden Then c = c + 1 Next px1 = Pt2PxY(aRows.Height / c) pxN = WorksheetFunction.Round(px1 * WinZoom / 100, 0) PixZoomY = pxN / px1 ' Debug.Print "Y " & WinZoom, pxN & "/" & px1, PixZoomY, aRows.Address(0, 0), c End Function
'Rem ユーザーフォームモジュール内で使用する場合の使用例 _/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/ 'Private Sub UserForm_Initialize() ' Dim myTop As Single, myLeft As Single ' Me.StartUpPosition = 0 ' Call GetTopLeftFromCellBR(ActiveCell, myTop, myLeft, Me.Height, Me.Width) ' Me.Top = myTop ' Me.Left = myLeft 'End Sub
（白茶） 2017/03/24(金) 21:58
あまり説得力はないかもしれませんが・・・
たとえば、私のコードで Const PTUNIT As Single = 0.75 'エクセル上のポイント値は0.75の倍数 といった定義をして、『おそらくエクセルはこういった丸めを行っているんだろうな』という計算をしています。
これは、かなり昔、xl2003時代に、k窓だったと記憶していますが、そこに書かれていた情報です。 少なくとも、私は ＭＳの公式ページで、この説明は読んでいません。 また、あれからバージョンもかわってきていて、そのエクセルの丸め基準も変わってきているかもしれません。
そういうこと以前に、DPIだのPPIだのZoomだのの値を用いて掛けたり割ったりしているわけですが、エクセルの浮動小数点誤差もあり 我々が計算する結果と、エクセル上の配置の実態の間に、わずかに誤差、差異が発生することは考えられます。
それが、小さな数値による座標であれば、誤差は誤差として受け入れ許容範囲でしょうが、CC65000 といった 縦も横も、膨大な数値の座標になると、その誤差の積み重ねが、大きな、とんでもない値になるのではと。
そう思っているんですが・・・
（β） 2017/03/25(土) 10:41
Excel で列の幅が決定されるしくみについて
https://support.microsoft.com/ja-jp/help/214123/description-of-how-column-widths-are-determined-in-excel
には「 行や列のスクロールを高速にするために、8 ピクセルの倍数で最も近似する値に切り上げられます」
という記述があります。
「8 ピクセルの倍数」というのは、
多分StandardWidth(文字数単位)を決定する際の丸め(72ピクセル⇔54ポイント)の事を言っているのでしょうから
本件とは関わりないものだとしても、
実際、シート上で列幅を弄っていくと、0.75単位でしか変化しないですし、
VBE上でユーザーフォームを編集していても0.75単位での補正がかかります。
私のコードでも「そういうものだ」として0.75単位(72÷96)の丸め処理を噛ませているのですが、
考えてみれば行高を弄った場合は0.25単位での丸めが行われている様ですし、
ユーザーフォームの編集中も縦方向は0.25単位で丸めが行われます。
しかも行高の方は1ポイント未満の場合の丸め方は、また別の様です。
一概に0.75単位で丸めてしまうのは良くなかったのかな?
とも考えているところです。
(とは言え、これ以上深く突き詰める気になれない)
また、ピクセルからポイントに変換する際の処理も、
切捨てなのか、切り上げなのか、四捨五入なのか、いわゆる偶数丸めなのか、
いまいち自信がありません(とりあえず切り捨ててますけど)
いずれにせよ、縮尺の処理は
「全体のピクセル距離 × ズーム値/100」
とするよりかは、
「単位行(単位列)あたりのピクセル距離 × ズーム値/100」
とした方が、
誤差は出にくいみたいですね。
肝心の「単位行(単位列)」が不明ですが・・・
（白茶） 2017/03/27(月) 11:24
ちょい訂正
>行高を弄った場合は0.25単位での丸めが行われている Heightの値ではなくRowHeightの値の事です。 関係あるのか無いのかは置いといて。
>しかも行高の方は1ポイント未満の場合の丸め方は、また別の様です。 なぜか再現できないす。 アレは何だったのか・・・?
>ユーザーフォームの編集中も縦方向は0.25単位で丸めが行われます。 こっちは完全にウソでしたね。 0.75単位だわ
（白茶） 2017/03/27(月) 11:54
お邪魔します。 UserFormが表示される座標基準はデスクトップ画面です。
VBAが持っている座標系関数はあくまでビジネスロジックであり 頼ることには限界があると思っていいでしょう。
なんだか話がどんどん遠くへ行ってしまいようで。。。 発想を変えたらどうですか？
ただ、Vista以降のOSにはWindow枠の太さがそれぞれ異なります。 「セルにぴったり」に表示するのはOSのVisualStyleに依存します。 その辺は 2〜4 pixelほど調整すれば見た目「ぴったり」効果は得られます。
下記サンプルは私の環境（Excel 2010, Windows 10）で作成したソースです。
※ Windows8だと右方向、下方向へ+4pixelでセルにピッタリの効果がありますね。
【現在選択セル上にFormを表示する】
'---（UserFormクラス）UserForm1----
Private Declare PtrSafe Function GetCaretPos Lib "User32" _
(ByVal lpPoint As LongPtr) As Long
Private Declare PtrSafe Function ClientToScreen Lib "User32" _
(ByVal hWnd As LongPtr, _
ByVal lpPoint As LongPtr) As Long
Private Declare PtrSafe Function GetFocus Lib "User32" _
() As LongPtr
Private Declare PtrSafe Function SystemParametersInfoW Lib "User32" _
(ByVal uiAction As Long, _
ByVal uiParam As Long, _
ByVal pvParam As LongPtr, _
ByVal fWinIni As Long) As Long
Private Const SPI_GETWORKAREA = &H30&
Private Sub UserForm_Initialize()
Const GAPX As Long = -2 'OSによる加減設定値
Const GAPY As Long = 0
Dim wd As Long, pt(1) As Long
Dim rt As Single, ptr As LongPtr
Dim rect(3) As Long
Dim acc As IAccessible
ptr = VarPtr(pt(0))
GetCaretPos ptr
ClientToScreen GetFocus(), ptr
Set acc = Me
acc.accLocation 0, 0, wd, 0
rt = InsideWidth / wd ' pt/px換算率
ptr = VarPtr(rect(0))
SystemParametersInfoW SPI_GETWORKAREA, 0, ptr, 0
rect(2) = rect(2) - Width / rt
rect(3) = rect(3) - Height / rt
If pt(0) < rect(0) Then pt(0) = rect(0)
If pt(0) > rect(2) Then pt(0) = rect(2)
If pt(1) < rect(1) Then pt(1) = rect(1)
If pt(1) > rect(3) Then pt(1) = rect(3)
StartUpPosition = 0
Left = (pt(0) + GAPX) * rt: Top = (pt(1) + GAPY) * rt
End Sub
'--（標準モジュール）----
Public Sub Main()
Application.OnTime Now, "ShowForm"
End Sub
Private Sub ShowForm()
UserForm1.Show
End Sub
（Abyss） 2017/03/28(火) 00:38
スレ、お借りします。
To Abyss さん
いつも（別板で）お世話になっております。（別板では UO3 という HN を使っております）
こちらには、いらっしゃらないのかなと、そう思いこんでいたんですが、過去ログを検索すると 数年前までは、結構、こちらでも回答されていたんですね。
見ておられないものだと思いこんで、勝手に私のレスの中でAbyssさんのお名前やコード掲載されているURLの紹介をしておりました。
そういえば、最近、γさんも
[[20170322021114]] 『pasteを実行するには』（yama）
ここで、Abyssさんのコードを参考提示されておられました。 （γさんも、私同様、別板では別HNを使っておられるようですが）
Abyssさんに教えていただいたコードは、せっせと、私のライブラリーにため込んでいます。 また、武器が１つ増えました。
ありがとうございます。
（β） 2017/03/28(火) 01:32
Abyssさん、ありがとうございます。 バッチリ解決です。
はー、GetCaretPos ですか。 そっちには全然アタマが行きませんでした。 そうよ。ActiveCellなんて正にCaretですわ・・・。
あと、ClientToScreen で Application.hwndではなくActiveWindowのハンドルを取る様に GetFocusを入れているところも地味にミソですね。(今度使う時に忘れそう)
私の場合ActiveCell以外のセルを基準に表示させることは無いだろうし、 仮にあったとしても、そのセルをActiveCellにすれば良いだけだし。 大袈裟かも知れませんが、これでいい仕事が出来そうです。
皆様、たいへんお世話になりありがとうございました。 (とりわけβさんには再々お付き合いいただき重ねてお礼申し上げます。 ありがとうございました。)
本件クローズです。
（白茶） 2017/03/28(火) 10:34
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.