[[20150602101200]] 『ユーザーフォームにカレンダー』(yuki) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『ユーザーフォームにカレンダー』(yuki)

ユーザーフォームにカレンダーを設置することは可能でしょうか?
アクセスは入っていないので、完全にエクセルだけで使えるようにしたいのですが。

< 使用 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


 カレンダーでは、この学校内の以下

[[20100728102355]] 

 調べてみてください。

 発端は、ラベルの垂直線上の中央揃えの方法だったのですが、
 これが以外な方法で実現できるというスレッドです。

 ここで
 nagashimaさんという方がこれを使ったカンレダーを紹介されています。

 カレンダーを二つのクラスモジュールで管理しています。

 私が少し使った限り、良いところは、

 フレームを作成した大きさにカレンダーを作成します。

 つまり、ユーザーフォーム上にフレームを配置することにより、フレームと同じ位置、大きさにカレンダーを
 作成することが出来ます。

 提供しているイベントは クリックとダブルクリック

 ラベルの垂直線上の中央揃えの方法が前半に記述されていますから、この施しをしなければなりません。
 じっくり読んでいけば 理解いただけるはずです。

 改良点

 他人が作ったコードですし、又非常に良いコードなので これに難を申し上げるのは気が引けますが、

 ラベルを中央ぞろえするために 簡単な bmpファイルを用意しなければなりませんが、これも
 コードで実現するとより良くなると思うこと。

 祝日もカレンダー内で管理していますが、祝日無のモードも用意しておいた方が安心なこと

 なんてことが私の感想ですが、良い仕様だと感じましたので ご紹介させていただきます。

  
(ichinose) 2015/06/02(火) 22:18

遅くなりましたがMookさん、稲葉さん、ichinoseさん、ありがとうございました。大変参考になります。
びっくりして声が出ませんでした。感激です!是非使用させていただきます。本当にありがとうございました。
(yuki) 2015/06/03(水) 13:20

稲葉さま

突然失礼いたします。

 非常に便利で、あり難く使わせて頂いております。
一つ確認したいことがあり、起票させて頂きました。
本来であれば、別スレッドを立ち上げるべきかもしれませんが。

カーソル

 現在は、カーソルが、”+ ”になっていますが
このカーソルを、通常の矢印等に変えることは可能でしょうか
もし可能なのであれば、どの部分をリメイクすればよろしいのでしょうか
ご教示頂きたくお願い申し上げます。

(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.