[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『DatePicker』（´・ω・`）
こちらの関連で、 [[20210614122645]] 自前のDatePickerが欲しくなったのでつくって見ました。 Userformのデザインをこの掲示板であげるのが難しかったのと 自分のHPとかもってないので、GoogleDriveへのリンクです。
パスワードはかけて無いので、コード丸見えです。 なので、自分のマクロに組み込むことも可能です。
私のことを信用・信頼出来る奇特な方しか ダウンロードしないだろうとは思いますが、 もし需要があれば使ってください。
2013と365で動くことは確認しています。
バグがあるかもしれませんが、申し訳ありませんが責任はもてません。 単機能です。日付を選択することしかできませんので 改造はどうぞご自由になさってください。
https://drive.google.com/file/d/1wkntlvYIktsh97Vcfy7enGniuA6Qsxwx/view?usp=sharing
＜ 使用 Excel：Excel2013、使用 OS：Windows10 ＞
問題あるようなら削除しますので、このスレッドに書き込んでお知らせください。 （´・ω・`） 2021/06/15(火) 19:51
作動しました。エラー無し。
（OK） 2021/06/15(火) 20:07
改造はどうぞご自由になさってください。
とのことですので、セルへの書き出しはご自分で
改造してね、ということですね。
（OK） 2021/06/15(火) 20:17
お試しくださりありがとうございます。 Excelの最新機能とか使ってないので旧バージョンでも動くとはおもってましたが 2007でも動くのが確かめられたのはありがたいです。 >セルへの書き出しはできないのね!!うふふ
Sheet1のダブルクリックでそのセルに書き込むイベントプロシジャは サンプルとしてつけてあります。コメントアウトして殺してありますが。 画面中央にユーザーフォームが表示されるんで、まぁあまり良くはないです （´・ω・`） 2021/06/15(火) 20:31
こんばんは ＾＾ 何時も、勉強させていただいております。 クラスももう忘れかけてましたので。。。謹んで拝読させて戴きます。 使わせて戴きますね、有難う御座います。m(__)m （隠居じーさん） 2021/06/15(火) 21:19
隠居じーさんさま おためしくださりありがとうございます。 工作キットのようなものだとおもって適当にあそんで見てください （´・ω・`） 2021/06/16(水) 09:24
イイですね、このサイズ。 別のUserForm上から呼び出して使うのにも自己主張が強くなり過ぎず、 あたかもUserForm上のControlのひとつとしての使用感が得られそうです。 参考にさせて頂きます。 (Win7(32bit)/Excel2010)
（白茶） 2021/06/16(水) 09:58
こんにちは ＾＾ m(_ _)m。。。ありがとうございます。
Ｅｘｃｅｌ ２０１６ ３６５タイプ Win( 32Bit ) ＯＳ Ｗｉｎ１０( 64Bit ) Ｈｏｍｅ （隠居じーさん） 2021/06/16(水) 10:26
>>別のUserForm上から呼び出して使う をちょっと試してみました。
Rem [UserForm1]モジュール ----------------------------------------------------------------------
Option Explicit
Private WithEvents Text1 As MSForms.TextBox
Private WithEvents Text2 As MSForms.TextBox
Private Sub Text1_DropButtonClick()
Dim posX As Single, posY As Single
With frmDatePicker
.StartUpPosition = 0
Call GetTopLeftFromMouseCur(posY, posX, .Height, .Width)
.Top = posY: .Left = posX
If .ShowDialog() = vbOK Then Text1.Value = .PickedDate
End With
End Sub
Private Sub Text2_DropButtonClick()
Dim posX As Single, posY As Single
With frmDatePicker
.StartUpPosition = 0
Call GetTopLeftFromMouseCur(posY, posX, .Height, .Width)
.Top = posY: .Left = posX
If .ShowDialog() = vbOK Then Text2.Value = .PickedDate
End With
End Sub
Private Sub UserForm_Initialize()
Set Text1 = Me.Controls.Add("Forms.TextBox.1", "Text1")
With Text1
.Top = 6!
.Left = 6!
.Width = 72!
.MaxLength = 10
.ShowDropButtonWhen = fmShowDropButtonWhenAlways
.DropButtonStyle = fmDropButtonStyleArrow
End With
Set Text2 = Me.Controls.Add("Forms.TextBox.1", "Text2")
With Text2
.Top = 26!
.Left = 6!
.Width = 72!
.MaxLength = 10
.ShowDropButtonWhen = fmShowDropButtonWhenAlways
.DropButtonStyle = fmDropButtonStyleArrow
End With
End Sub
Rem [StartupPos]モジュール ---------------------------------------------------------------------
Option Explicit
Option Private Module
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 = 88&
Private Const LOGPIXELSY = 90&
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As apiCursorPos) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Property Get xDPI() As Long '水平DPI
xDPI = GetDPI(LOGPIXELSX)
End Property
Private Property Get yDPI() As Long '垂直DPI
yDPI = GetDPI(LOGPIXELSY)
End Property
Private Property Get xlPPI() As Long 'エクセルPPI
xlPPI = Application.InchesToPoints(1)
End Property
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)
Rem マウスカーソル座標でフォーム表示する為のTopとLeftを得る(画面からのはみ出し補正付き)
Rem 引数 LimitToEdge --- 画面の右または下にフォームがはみ出そうな場合の基点座標の補正方法を切り替える
Rem True ------------- はみ出る幅及び高さ分だけ左上方向に減算する(画面端にくっ付く感じでフォームを表示)
Rem 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 ピクセル⇔ポイント変換
Private 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
Private Function Pt2PxX(aPoint As Single) As Long '水平ポイントをピクセルに変換
Pt2PxX = Int(aPoint * xDPI / xlPPI)
End Function
Private Function Px2PtY(aPixel As Long) As Single 'ピクセルを垂直ポイントに変換
Px2PtY = Int((aPixel * xlPPI / yDPI) / (xlPPI / yDPI)) * (xlPPI / yDPI)
End Function
Private Function Pt2PxY(aPoint As Single) As Long '垂直ポイントをピクセルに変換
Pt2PxY = Int(aPoint * yDPI / xlPPI)
End Function
Rem DPI取得(内部処理)
Private Function GetDPI(nIndex As Long) As Long
Dim hDC As Long
hDC = GetDC(Application.hwnd)
GetDPI = GetDeviceCaps(hDC, nIndex)
ReleaseDC &H0, hDC
End Function
イイ感じです。 こういう場合は[OK]ボタン経由せずとも、 日付ラベルを押した時点でfrmDatePickerがHideされる様に弄った方が よりスムーズな操作感になりそうですね。
（白茶） 2021/06/16(水) 11:07
白茶さま 表示位置を自由に設定しようとすると、やっぱりAPI使うしかないですよね．．． APIは普段全然使わないのでよく分かってなかったので、参考になりました。 ありがとうございます。 （´・ω・`） 2021/06/17(木) 09:29
ActiveWindow に対して使えば良いです。
https://docs.microsoft.com/ja-jp/office/vba/api/excel.window.pointstoscreenpixelsx
（AddinBox_Tsunoda） 2021/06/17(木) 10:27
PickedDateの4行目
Weekday(NewDate, vbMonday)
のところですが、ここを
Weekday(DateSerial(Year(NewDate), Month(NewDate), 1), vbMonday)
や
(Weekday(DateSerial(Year(NewDate), Month(NewDate), 1)) - 1)
等にしてWeekday値を得るためのその月の基準日を固定しないとカレンダーがずれます。
（げん） 2021/06/17(木) 12:09
AddinBox_Tsunodaさん 勉強させていただきました。 角団のHPやここでの過去ログの議論も参考になりました。
げんさん まったくご指摘のとおりでございます。 もし使う人がいらっしゃれば、修正してお使いいただければと思います。 ファイルは後日差し替えます （´・ω・`） 2021/06/18(金) 08:55
あ、差し替えされるんであれば、ちょっとついでに...^^;
フォーム右上の[×]ボタンで閉じられる場合の対処も入れといた方がイイかもです。
.ShowDialogで[OK]ボタン押してもHideされるだけの状態ですから、 続けてもう一度.ShowDialogして、今度は[×]ボタンで閉じられたら ShowDialogの戻り値に前回の vbOK がセットされる可能性があります。 そうなると 後続の処理でPickedDateを参照しようとしてオートメーションエラーになってしまいます。
例えば 1回目 If .ShowDialog() = vbOK Then xxx = .PickedDate (Resultは vbOKのままHideされる)
2回目
If .ShowDialog() = vbOK Then xxx = .PickedDate
↑ここで[×]ボタンで閉じられても戻り値は vbOKのままなので
.PickedDateの工程でオートメーションエラーが発生する
それか、 ShowDialog内の End Function 手前で UnLoad Me しちゃうとか...?
一応ご報告迄
（白茶） 2021/06/18(金) 13:30
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.