[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ユーザーフォームにカレンダー』（ｙｕｋｉ）
ユーザーフォームにカレンダーを設置することは可能でしょうか？
アクセスは入っていないので、完全にエクセルだけで使えるようにしたいのですが。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
excel ユーザーフォーム カレンダー とかでWEB検索すると自作の方法が見つかりますよ。
（ウッシ） 2015/06/02(火) 11:24
シェルのウィンドウがチラッと表示されるのを何とかしたいですが、 お遊びで PowerShellを利用した例です。
Sub PowerShellCalender()
Dim pss As String
pss = "Function Get-Date {" _
& "[System.Reflection.Assembly]::LoadWithPartialName('System.windows.forms') | Out-Null;" _
& " $WinForm = New-Object Windows.Forms.Form;" _
& " $WinForm.Size = New-Object Drawing.Size(420,180);" _
& " $WinForm.text = 'Calendar Control';" _
& " $Calendar = New-Object System.Windows.Forms.MonthCalendar;" _
& " $Calendar.MaxSelectionCount = 356;" _
& " $Calendar.SetCalendarDimensions([int]3,[int]1);" _
& " $WinForm.Controls.Add($Calendar);" _
& " $WinForm.Add_Shown($WinForm.Activate());" _
& " $WinForm.showdialog() | Out-Null;" _
& " $Calendar.SelectionRange; }" _
& " $dates = Get-Date;" _
& " $tb = New-Object System.Windows.Forms.TextBox;" _
& " $tb.Text =($dates.Start).tostring('yyyy-MM-dd') + ',' + ($dates.End).tostring('yyyy-MM-dd');" _
& " $tb.SelectAll(); $tb.Copy();"
CreateObject("WScript.Shell").Run "PowerShell -WindowStyle Hidden -Command " & pss, , True
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '// DataObject
.GetFromClipboard
If InStr(.GetText, ",") > 0 Then
msg = Split(.GetText, ",")
MsgBox "開始日:" & msg(0) & vbNewLine _
& "終了日:" & msg(1)
Else
MsgBox .GetText
End If
End With
End Sub
正統派は多分こういった感じでしょうけれど・・・。 http://www.h3.dion.ne.jp/~sakatsu/index.htm http://excel-2010.seesaa.net/article/154360048.html
（Mook） 2015/06/02(火) 13:07
自分用に練習兼ねて作ったものを、配布用に色々削って提示します。 個人的には満足。
多分面倒だと思いますので、パッケージ化して配布されたツール使ったほうが早いです。 ラベルしかコントロール配列使っていないので、37個クリックイベント書けばクラス モジュールは不要です。
01)クラスモジュールを2つ挿入してください
02)それぞれ、下記の名前にしてください
clsUFCalendarMain <--以降Mainと呼びます
clsUFCalendarSub <--以降Subと呼びます
03)ユーザーフォームを追加してください（コントロールは必要ありません） 04)フォームの名前を UFCalendarSimple としてください
05)Mainに以下のコードを入れてください
Option Explicit
Event Click(ByVal ID As Long)
'==================================================
Private DIC As Object
'==================================================
'==================================================
Private Sub Class_Initialize()
'==================================================
Set DIC = CreateObject("Scripting.Dictionary")
End Sub
'==================================================
Private Sub Class_Terminate()
'==================================================
Me.Clear
End Sub
'==================================================
'★Property Setで引数を二つにし、添え字でオブジェクトの代入ができるようにする
Public Property Set Ctrl(ID As Long, obj As Object)
'==================================================
Dim clsObj As Object
Set clsObj = New clsUFCalendarSub
With clsObj
.ID = ID
.Method = "CallBackAndRaseEvent"
Set .Parent = Me
Set .obj = obj
End With
DIC.Add ID, clsObj
End Property
'==================================================
Public Property Get Ctrl(ID As Long) As Object
Set Ctrl = DIC(ID).obj
End Property
'==================================================
'★子クラスのコールバック
Public Sub CallBackAndRaseEvent(ParamArray arg() As Variant)
Select Case arg(0)
Case "Click": RaiseEvent Click(arg(1))
End Select
End Sub
'==================================================
Public Sub Clear()
'==================================================
Set DIC = Nothing
End Sub
06)Subに以下のコードを入れてください
Option Explicit
'============================================================
'このクラスの疑似オブジェクトは『ラベル』
'============================================================
Public WithEvents obj As MSForms.Label
'============================================================
'共通の設定
'============================================================
Public Parent As Object
Public ID As Long
Public Method As String
'============================================================
'イベント一覧
'============================================================
Private Sub obj_Click()
CallByName Parent, Method, VbMethod, "Click", ID
End Sub
07)フォームに以下のコードを追加してください
Option Explicit
Private WithEvents clsC As clsUFCalendarMain
Private WithEvents CB As MSForms.ComboBox
Private WithEvents SP As MSForms.SpinButton
Private LB1(0 To 2) As MSForms.Label
Private IniDate As Date
'==================================================
'列挙型 色を指定してください"&H00"と"BBGGRR"の組み合わせです。
Private Enum clr
'==================================================
'色（http://iro-color.com/colorchart/arrangement/system-blue.html）
ufBGColor = CLng("&H00E9CCBB") 'ユーザーフォームの背景
lbBGColor = CLng("&H00F9EFEA") 'ラベルの背景
lbBDColor = CLng("&H00D29B6C") 'ラベルの罫線
nwBGColor = CLng("&H00DAAB88") '現在日付の背景
End Enum
'==================================================
'列挙型 各コントロールのサイズがあります。
Private Enum Sz
'==================================================
lbAll = 18
lbFont = 11.25
lbWidth = 42
cbWidth = 108
cbHeight = 27
cbFont = 14.25
spHeight = 24
spWidth = 18
ufMgLeft = 6
ufMgTop = 6
ctMgTop = 6
edMgLeft = 10
edMgTop = 30
End Enum
'==================================================
'【EV】ラベルのクリックイベント
Private Sub clsC_Click(ByVal ID As Long)
'==================================================
Dim LB As MSForms.Label
Set LB = clsC.Ctrl(ID)
With LB
If ID < 99 Then
Selection.Value = CDate(Format(CB.Value & .Caption & "日", "yyyy/mm/dd"))
Else
Selection.Value = Date - (100 - ID)
End If
End With
Unload Me
End Sub
'==================================================
'【EV】イニシャライズイベント 引数を渡せないので、FormIniメソッドに渡す
Private Sub UserForm_Initialize()
'==================================================
Dim i As Long
mkCtrl
'//コントロールにイベントを持たせるため、クラスに登録する
Set clsC = New clsUFCalendarMain
For i = 1 To 37
Set clsC.Ctrl(i) = Me.Controls("d" & Right("0" & i, 2))
Next i
'//こちらは「昨日・今日・明日」のほう
Set clsC.Ctrl(99) = LB1(0)
Set clsC.Ctrl(100) = LB1(1)
Set clsC.Ctrl(101) = LB1(2)
End Sub
'==================================================
'【EV】EVターミネートイベント
Private Sub UserForm_Terminate()
'==================================================
clsC.Clear
Set clsC = Nothing
End Sub
'==================================================
'Showの代わりに、日付をセットする
Public Sub FormIni(myDate As Variant)
'==================================================
If IsDate(myDate) Then
IniDate = CDate(myDate)
Else
IniDate = Date
End If
DLabelIni Weekday(Format(IniDate, "yyyy/mm/01")), DateSerial(Year(Date), Month(Date) + 1, 0)
YMCmbIni IniDate
Me.Show vbModeless
'ユーザーフォームからフォーカスを外し、ワークシート選択状態にする
AppActivate Application.Caption
Application.ThisWorkbook.Activate
End Sub
'==================================================
'★ラベルを書き換えるメインプロシジャー
Private Sub DLabelIni(fd As Long, ed As Date)
'==================================================
Dim d As Long
Dim i As Long
Dim LB As MSForms.Label
Dim ThisMon As Boolean
ThisMon = Format(IniDate, "yyyymm") = Format(ed, "yyyymm")
d = 1
'Labelコントロールを疑似オブジェクトにセットする
For i = 1 To 37
Set LB = clsC.Ctrl(i)
If d = 1 Then
If i = fd Then
DLabelIniSub LB, d, 1, True, ThisMon, d
Else
DLabelIniSub LB, d, 0, False, ThisMon, Day(CDate(Format(Date, "yyyy/mm/01")) - (fd - i))
End If
ElseIf d <= Day(ed) Then
DLabelIniSub LB, d, 1, True, ThisMon, d
Else
DLabelIniSub LB, d, 1, False, ThisMon, Day(ed + (d - Day(ed)))
End If
Next i
End Sub
'==================================================
'ラベルの日付を書き換えるサブプロシジャー
Private Sub DLabelIniSub(ByRef LB As MSForms.Label, ByRef d As Long, ByVal Add As Long, ByVal Ena As Boolean, ByVal ThisMon As Boolean, ByVal Cap As String)
'==================================================
With LB
.Enabled = Ena
.Caption = Cap
.BorderColor = clr.lbBDColor
If ThisMon And Day(IniDate) = d Then
.BackColor = clr.nwBGColor
Else
.BackColor = clr.lbBGColor
End If
d = d + Add
End With
End Sub
'==================================================
'コンボボックスの値が変更になったら、ラベルの日付を書き換える
Private Sub cb_Change()
'==================================================
Dim SDate As Date
With CB
SDate = DateValue(.Value)
DLabelIni Weekday(SDate), DateSerial(Year(SDate), Month(SDate) + 1, 0) '★
End With
End Sub
'==================================================
'コンボボックスのリストを設定する SDateを基準日に、前後24カ月
Private Sub YMCmbIni(ByVal SDate As Date)
'==================================================
Dim i As Long
For i = -24 To 24
CB.AddItem Format(DateSerial(Year(SDate), Month(SDate) + i, 1), "yyyy年m月")
Next i
CB.Value = Format(Date, "yyyy年m月")
End Sub
'==================================================
'スピンボタンの設定 押すとコンボボックスの値が前になる
Private Sub sp_SpinDown()
'==================================================
With CB
.ListIndex = Application.Max(.ListIndex - 1, 0)
End With
End Sub
'==================================================
'スピンボタンの設定 押すとコンボボックスの値が先になる
Private Sub sp_SpinUp()
'==================================================
With CB
.ListIndex = Application.Min(.ListIndex + 1, .ListCount - 1)
End With
End Sub
'==================================================
'フォームのフォーマットを作成する
Private Sub mkCtrl()
'==================================================
Dim i As Long
Dim LB2 As MSForms.Label
Dim wkNum As Long
Dim lbNam As String
'コンボボックスの設定
Set CB = Me.Controls.Add("Forms.ComboBox.1", "ComboBox1", True)
With CB
.Top = Sz.ufMgTop
.Left = Sz.ufMgLeft
.Height = Sz.cbHeight
.Width = Sz.cbWidth
.Font.Name = "メイリオ"
.Font.Size = Sz.cbFont
End With
'スピンボタンの設定
Set SP = Me.Controls.Add("Forms.SpinButton.1", "SpinButton1", True)
With SP
.Top = Sz.ufMgTop
.Left = Sz.ufMgLeft + Sz.cbWidth
.Height = Sz.spHeight
.Width = Sz.spWidth
.Orientation = fmOrientationVertical
End With
'ラベル（昨日今日明日）の設定
For i = 0 To 2
Set LB1(i) = Me.Controls.Add("Forms.Label.1", "cl" & Split("Yesterday,Today,Tommorow", ",")(i), True)
With LB1(i)
.BackColor = clr.lbBGColor
.BorderStyle = fmBorderStyleSingle
.BorderColor = clr.lbBDColor
.Top = CB.Top + Sz.cbHeight + Sz.ctMgTop
.Left = Sz.lbWidth * i + Sz.ufMgLeft
.Height = Sz.lbAll
.Width = Sz.lbWidth
.TextAlign = fmTextAlignCenter
.Font.Name = "メイリオ"
.Font.Size = Sz.lbFont
Select Case i
Case 0
.ForeColor = vbBlue
.Caption = "昨日"
Case 1
.ForeColor = vbBlack
.Caption = "今日"
Case 2
.ForeColor = vbRed
.Caption = "明日"
End Select
End With
Next i
'ラベル（日にち）の設定
wkNum = 7
lbNam = ""
For i = 1 To 37 + wkNum
If i <= wkNum Then
lbNam = Split(",Sun,Mon,Tue,Wsd,Thu,Fri,Sat", ",")(i)
Else
lbNam = "d" & Right("0" & i - wkNum, 2)
End If
Set LB2 = Me.Controls.Add("Forms.Label.1", lbNam, True)
With LB2
.BackColor = clr.lbBGColor
.BorderStyle = fmBorderStyleSingle
.BorderColor = clr.lbBDColor
.Top = Sz.lbAll * (Application.WorksheetFunction.Ceiling(i / 7, 1) - 1) + LB1(2).Top + Sz.lbAll + Sz.ctMgTop
.Left = Sz.lbAll * ((i - 1) Mod 7) + Sz.ufMgLeft
.Height = Sz.lbAll
.Width = Sz.lbAll
.TextAlign = fmTextAlignCenter
.Font.Name = "メイリオ"
.Font.Size = Sz.lbFont
If i < 8 Then
.Caption = Split("日,月,火,水,木,金,土", ",")(i - 1)
Else
.Caption = i - 7
.MousePointer = fmMousePointerCross
End If
Select Case i Mod 7
Case 1: .ForeColor = vbRed
Case 0: .ForeColor = vbBlue
End Select
End With
Next i
With Me
.Width = LB1(2).Left + Sz.lbWidth + Sz.edMgLeft
.Height = LB2.Top + Sz.lbAll + Sz.edMgTop
.Caption = "カレンダー"
.BackColor = clr.ufBGColor
End With
End Sub
08)呼び出し方法は以下の通りです。
Sub HowToUse()
UFCalendarSimple.FormIni Date
End Sub
ユーザーフォームの日付や「今日・明日」等のラベルをクリックすると、
現在選択しているセルに日付が入力されます。
必要に応じて、selection_Changeイベントなどと組み合わせて使ってください。
特定のセルに日付を入力させたい場合は、フォームのプロシジャー
'==================================================
'【EV】ラベルのクリックイベント
Private Sub clsC_Click(ByVal ID As Long)
'==================================================
のSelection.Valueを調整してください。
（稲葉） 2015/06/02(火) 13:48
選択範囲の開始と終了を表示するようにちょっと上のコードを修正。
（Mook） 2015/06/02(火) 18:58
カレンダーでは、この学校内の以下
調べてみてください。
発端は、ラベルの垂直線上の中央揃えの方法だったのですが、 これが以外な方法で実現できるというスレッドです。
ここで nagashimaさんという方がこれを使ったカンレダーを紹介されています。
カレンダーを二つのクラスモジュールで管理しています。
私が少し使った限り、良いところは、
フレームを作成した大きさにカレンダーを作成します。
つまり、ユーザーフォーム上にフレームを配置することにより、フレームと同じ位置、大きさにカレンダーを 作成することが出来ます。
提供しているイベントは クリックとダブルクリック
ラベルの垂直線上の中央揃えの方法が前半に記述されていますから、この施しをしなければなりません。 じっくり読んでいけば 理解いただけるはずです。
改良点
他人が作ったコードですし、又非常に良いコードなので これに難を申し上げるのは気が引けますが、
ラベルを中央ぞろえするために 簡単な bmpファイルを用意しなければなりませんが、これも コードで実現するとより良くなると思うこと。
祝日もカレンダー内で管理していますが、祝日無のモードも用意しておいた方が安心なこと
なんてことが私の感想ですが、良い仕様だと感じましたので ご紹介させていただきます。
（ichinose） 2015/06/02(火) 22:18
突然失礼いたします。
非常に便利で、あり難く使わせて頂いております。 一つ確認したいことがあり、起票させて頂きました。 本来であれば、別スレッドを立ち上げるべきかもしれませんが。
カーソル
現在は、カーソルが、”＋ ”になっていますが このカーソルを、通常の矢印等に変えることは可能でしょうか もし可能なのであれば、どの部分をリメイクすればよろしいのでしょうか ご教示頂きたくお願い申し上げます。
（aki） 2015/10/03(土) 20:57
横から失礼します。 便利なコードですねぇ。
全部に目を通してはいませんが MousePointer プロパティに fmMousePointerCross をセットしているところがありますよね。 このプロパティで、様々な形状を指定できます。
http://excwlvba.blogspot.jp/2013/05/userform_8.html
あたりがわかりやすいかも。
（β） 2015/10/03(土) 21:36
ありがとうございました。 ばっちりです！ 今後とも宜しくお願い申し上げます。 （aki） 2015/10/04(日) 01:32
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.