[[20100728102355]] 『ユーザーフォームのラベル文字をHeightの中央配置』(まき) >>BOT

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

 

『ユーザーフォームのラベル文字をHeightの中央配置』(まき)

Excel2003,Vista

いつも色々参考にさせて頂いております。

 検索したつもりですが、見当たりませんでしたので質問させて頂きます。
 ユーザーフォーム上でラベルを配置しheightを大きくし、この中央に文字を配置したい
 と考えています。この時にBoderStyle:1としています。シートのセルで言う配置、縦位
 置、中央揃えで外周を線で囲いたいのを行いたいです。ラベルを2個重ねれば出来るの
 ですが、少し芸が無い様に思えたので質問させて頂きました。
 ラベルのプロパティに同設定が無いので(多分)、上記の様にラベルを2つ重ねないと
 出来ないのでしょうか。

以上よろしくお願い申し上げます。


 >少し芸が無い様に思えたので質問させて頂きました。
 >上記の様にラベルを2つ重ねないと出来ないのでしょうか。
 芸がないとは思いませんが、この方法しかなさそうですねえ!!
 Vbprojectを操作してこの二つのラベルを重ねて、
 きれいに縦方向のセンタリングを自動化するVBAを
 作成することを考えるのはどうですか? 芸があると思いますよ!!

 ichinose


ichinose様

ご回答頂き有り難うございました。

 やっぱりセルの様に出来ない見たいなので、2つのラベルを重ねる様に致します。本当は、枠の線の太
 さも位置により変えたかったのですが。。。もう少しユーザーフォームに線等の使える物が欲しいです。。

以上よろしくお願い申し上げます。


 >本当は、枠の線の太さも位置により変えたかったのですが

 これは、ラベルを細い線して代用する方法が考えられます。

 新規ブックにて、ユーザーフォーム(UserForm1)を作成してください。
 コントロールは、コードで作成しますので、何も配置しないでください。

 「ツール」---「マクロ」----「セキュリティ」とクリックし、セキュリティダイアログを表示させます。

 信頼のおける発行元 タブにて、
 Visual Basic プロジェクトへのアクセスを信頼する にチェックを入れてください。

 標準モジュールに

 '====================================================================================
 Sub sample()
    Dim lblb1 As Object
    Dim lblc1 As Object
    Dim lblb2 As Object
    Dim lblc2 As Object
    Dim lblb3 As Object
    Dim lblc3 As Object
    Dim vbp As Object
    With ThisWorkbook.VBProject
        Set vbp = .VBComponents("UserForm1")
        vbp.Activate
        vbp.Designer.Controls.Clear 'コントロールの全消去
        Set lblb1 = vbp.Designer.Controls.Add("Forms.Label.1")
        With lblb1
           .Left = 30
           .Top = 18
           .Width = 84
           .Height = 27
           .SpecialEffect = 6
        End With
        Set lblc1 = vbp.Designer.Controls.Add("Forms.Label.1")
        With lblc1
           .Left = 33
           .Top = lblb1.Top + 8
           .Width = 84
           .Height = 27
           .Caption = "sample"
           .AutoSize = True
           .Font.Size = 9
        End With
        Set lblb2 = vbp.Designer.Controls.Add("Forms.Label.1")
        With lblb2
           .Left = 30
           .Top = 50
           .Width = 84
           .Height = 27
        End With
        Set lblc2 = vbp.Designer.Controls.Add("Forms.Label.1")
        With lblc2
           .Left = 33
           .Top = lblb2.Top + 8
           .Width = 84
           .Height = 27
           .Caption = "sample"
           .AutoSize = True
           .Font.Size = 9
        End With
        With vbp.Designer.Controls.Add("Forms.Label.1")
           .Left = lblb2.Left - 1.5
           .Top = lblb2.Top - 1.5
           .Width = lblb2.Width + 1.5
           .Height = 1.5
           .BackColor = 0
        End With
        With vbp.Designer.Controls.Add("Forms.Label.1")
           .Left = lblb2.Left - 1.5
           .Top = lblb2.Top - 1.5
           .Width = 1.5
           .Height = lblb2.Height + 1.5
           .BackColor = 0
        End With
        With vbp.Designer.Controls.Add("Forms.Label.1")
           .Left = lblb2.Left - 1.5
           .Top = lblb2.Top + lblb2.Height - 1.5
           .Width = lblb2.Width + 1.5
           .Height = 1.5
           .BackColor = 0
        End With
        With vbp.Designer.Controls.Add("Forms.Label.1")
           .Left = lblb2.Left + lblb2.Width
           .Top = lblb2.Top - 1.5
           .Width = 1.5
           .Height = lblb2.Height + 1.5
           .BackColor = 0
        End With
        Set lblb3 = vbp.Designer.Controls.Add("Forms.Label.1")
        With lblb3
           .Left = 30
           .Top = 100
           .Width = 84
           .Height = 27
        End With
        Set lblc3 = vbp.Designer.Controls.Add("Forms.Label.1")
        With lblc3
           .Left = 33
           .Top = lblb3.Top + 8
           .Width = 84
           .Height = 27
           .Caption = "sample"
           .AutoSize = True
           .Font.Size = 9
        End With
        With vbp.Designer.Controls.Add("Forms.Label.1")
           .Left = lblb3.Left - 2.25
           .Top = lblb3.Top - 2.25
           .Width = lblb3.Width + 2.25
           .Height = 2.25
           .BackColor = 0
        End With
        With vbp.Designer.Controls.Add("Forms.Label.1")
           .Left = lblb3.Left - 2.25
           .Top = lblb3.Top - 2.25
           .Width = 2.25
           .Height = lblb3.Height + 2.25
           .BackColor = 0
        End With
        With vbp.Designer.Controls.Add("Forms.Label.1")
           .Left = lblb3.Left - 2.25
           .Top = lblb3.Top + lblb2.Height - 2.25
           .Width = lblb3.Width + 2.25
           .Height = 2.25
           .BackColor = 0
        End With
        With vbp.Designer.Controls.Add("Forms.Label.1")
           .Left = lblb3.Left + lblb2.Width
           .Top = lblb3.Top - 2.25
           .Width = 2.25
           .Height = lblb3.Height + 2.25
           .BackColor = 0
        End With
    End With
 End Sub

 sampleを実行してください。VBEにて、UserForm1を確認してください。
 枠線の太さが違うラベルが3っつ作成されるはずです。
 いろんなコントロールをあわせて作成されているので、それぞれのラベルは、グループ化しておくと
 扱いが便利です。コードでのグループ化の方法がわかりませんでした。
 知っている方がおられたらお願いします。

 コードで作成されたラベルは、手動操作で作成可能です。

 尚、sampleで確認後は、

 >信頼のおける発行元 タブにて、
 >Visual Basic プロジェクトへのアクセスを信頼する にチェックを入れてください。

 は、元に戻しておいてください。

 前投稿で
 >Vbprojectを操作してこの二つのラベルを重ねて、
 >きれいに縦方向のセンタリングを自動化するVBAを
 >作成することを考えるのはどうですか?

 とう申し上げました。
 上記コードは、単にラベル作成サンプルに過ぎません。
 Vbprojectを操作すれば、作成できるというサンプルを提示しました。

 これを操作して、汎用的にセンタリングや枠線の太さを変更できるラベル作成
 プログラムを考えては?  作れば、便利そうですよね!!

 ichinose


ichinose 様

 おはようございます、まきです。

 さて、ichinose様のサンプルを動かしてみました。言われた通りの3個の枠が太さ違いで描画されてい
 ます。私のレベルでは、マクロで描画する事が出来ません。今回のサンプルを勉強させて頂き、私の今
 作成しているフォームに反映出来る様試してみます。

 正直びっくりでした。。。。凄いです。

 有り難うございました。

ラベル中央(縦・横中央)配置で良いのならば
Picture に単色イメージを指定(単色イメージはなぜか表示されません)
PicturePositionを12-fmPicturePositionCenterを指定。

これで、Caption指定文字はラベル中央に表示されます。
※単色イメージが反映されない理由が判らない。

(KobayashiCttn) 2014/02/01(土) 17:52


KobayashiCttn さま

私も「ラベルの縦中央配置」でずっと苦しんでいました。
こんな方法があったとは知りませんでした。
教えて頂いてとても嬉しいです。

私も色々試してみたところ、
「単色イメージが反映されない」現象が少しだけ詳しくわかりました。

Pictureプロパティを持つコントロールが、
LoadPictureで画像を読むとき、読み方に2種類があるようです。
(Aグループ)Image、Page、Frame
       … 画像ををのまま表示する。
(Bグループ)Label、CommandButton、ToggleButton、OptionButton、CheckBox
       … 画像の左下隅にある色は、BackColorの色で表示する。

尚、私のPC環境は Windows8.1 + Excel2007 です。

(nagashima) 2014/02/07(金) 12:07


 >PicturePositionを12-fmPicturePositionCenterを指定。
 本当ですね!! 知りませんでした。情報、ありがとうございます。

 >単色イメージはなぜか表示されません
 の意味がわかりませんでしたが、Excelで作図する塗りつぶし四角形をこのラベルのPictuteに
 設定すると単色背景色は設定できそうですね!!

 手動操作では、

 ・ ラベルコントロールに合わせたサイズの四角形を作成する。これをコピー

 ・ VBEにて、当該ラベルコントロールを選択する。

 ・ F4キーを押して表示されるプロパティ一覧を表示させ、Picture項目を選択。

 ・ Ctrl+Vで貼付け で四角形が当該ラベルコントロールのPictureとして、設定されます。

 Vbprojectを操作して、これを簡単に実現できるツールが作れそうと試してみました。

 APIのGetClipboardData、OleCreatePictureIndirectで出来ると思ったのですが、
 確かに、これでラベルコントロールには、作成した四角形が反映され正しくCaptionプロパティも
 縦センターに配置されるのですが、複数のラベルコントロールにこの処理を行うと、ブックの保存が
 出来ないのです。Excel2010+Win7で試したので、32Bit、64Bitの違いでうまくいかないのかなあ
 と思いましたが、Excel2002+Win2000でも結果は同じでした。
 因みにエラーメッセージは「パス名が無効です」という内容でした。

 尚、事後設定(UserForm_Activateイベント又は、UserForm_Initializeイベントなどで前述のAPIを使ってのラベルコントロールの縦のセンターリング)では、正常に作動します。

 でも、これだと毎回このセンターリングのコードをぶら下げなければならないので、何とか事前設定で
 実現できないかと思い、以下の仕様にしてみました。

 まず、Vbprojectを操作しますから、「VBAプロジェクト オブジェクト モデルへのアクセスを信頼する」を有効にしておいおてください。この操作は、バージョンによって違うので省略。

 このコードの実行終了後は、無効にしておいてください。

 プログラム名

 選択されたラベルコントロールの縦のセンター配置

 仕様

 VBEにて、ユーザーフォーム上に作成したラベルコントロールのCaptionの縦センターリングを行います。

 ラベルコントロールの背景色は、Backcolorプロパティの設定に依存します。
 但し、パレットカラーのみで、システムカラーは不可。

 操作方法

 ・新規ブックを作成してください。

 ・VBEにて、ユーザーフォームを作成して、縦センターリングしたいラベルコントロールを二つほど作成してください。

 ・縦センターリングをの実現するために四角形をPictureプロパティに設定するのですが、その色を
   Backcolorプロパティのパレットカラーで指定してください。

 ・Backcolorプロパティの設定が終わりましたら、対象ラベルコントロールを選択してください。
   複数のラベルコントロールを選択してもよいです。

 ・選択した状態で「ツール」---「マクロ」とクリックし、マクロダイアログを表示させます。

 ・マクロの場所として、「選択されたラベルコントロールの縦のセンター配置」があるブックを選択します。

 ・選択されたラベルコントロールの縦のセンター配置 を実行します。

 ・選択されたラベルコントロールのCaptionは、縦のセンター配置されて表示されます。

 コード

 標準モジュールに

 Option Explicit
 Sub 選択されたラベルコントロールの縦のセンター配置()
    Const Graghfl = "graph.gif"
    Dim vbp As Object
    Dim ctrl As Object
    Dim sht As Worksheet
    Dim pic As StdPicture
    Set vbp = Application.VBE.SelectedVBComponent
    If vbp.Type = 3 Then
       vbp.DesignerWindow.SetFocus
       vbp.Activate
       Set sht = Workbooks.Add.Worksheets(1)
       On Error Resume Next
       For Each ctrl In vbp.Designer.Selected
          Err.Clear
          ctrl.PicturePosition = 12
          If Err.Number = 0 Then
             sht.Parent.Activate
             sht.Activate
             With sht.ChartObjects.Add(100, 100, ctrl.Width, ctrl.Height)
                .Activate
                .Chart.ChartArea.Border.LineStyle = 0
                .Chart.ChartArea.ClearContents
                .Chart.ChartArea.Select
                With .Chart.Rectangles.Add(0, 0, ctrl.Width, ctrl.Height)
                   .Interior.Color = ctrl.BackColor
                   .Border.Color = ctrl.BackColor
                End With
               .Chart.Export ThisWorkbook.Path & "\" & Graghfl
               .Delete
            End With
            ctrl.Picture = LoadPicture(ThisWorkbook.Path & "\" & Graghfl)

          End If
       Next
       sht.Parent.Close False
       Kill ThisWorkbook.Path & "\" & Graghfl
    End If
 End Sub

 上記コードのあるブックは、一度保存してから、使用してください。

 以上です。試してみてください。

 PS
 先週に続き、昨日からの雪、甲府では、初めて体験する大雪です。2/15 6:20 80Cmぐらいに見えます。隣の駐車場の車が雪で見えません。
 甲府って、そんなに雪は降らないんです。雪かきをしていて、かいてもかいても、減らない雪に
 恐怖さえ感じました。東北の方は、これが日常茶飯事なんですから、大変ですねえ

(ichinose@一日、雪かき) 2014/02/15(土) 06:30


ichinose 様

こんばんは、nagashimaです。

私は「単色イメージはなぜか表示されません」の価値は、
コードでBackColorプロパティの値を変更することにより、
実行時に任意の背景色を設定できることにあるように思いました。

<応用例1>
Captionで指定した文字列をそのまま表示させる場合は、
Paintソフトなどで作成した、1×1ピクセルの大きさの画像ファイルを、Pictureプロパティに設定すれば、
文字列の位置をPicturePositionプロパティで設定できるし、
BackColorプロパティもそのまま有効になる。

<応用例2>
フラットなボタンの代用として、ラベルを使う場合に、
例えば下図のようなボタンイメージを作るとして(「進むボタン」とかでよくあるやつです)、
三角の内側を黒色とし、三角の外側を白色とした画像をファイルを、Pictureプロパティに設定すれば、
外側の白色の部分は、画像の左下隅にある色なので、BackColorプロパティで任意の色に変更できる。
(※Caption=""としています。)

  −−−−−−−
 |            |
 |   |\     |
 |   |  \   |
 |   |  /   |
 |   |/     |
 |            |
  −−−−−−−

PS
京都です。雨で雪もほとんど消えてしまいました。2/15 22:17。

(nagashima) 2014/02/15(土) 22:24


 透明の小さい四角形で確認しました。これだと、小さい画像だけ用意すれば、コードは要りませんね。
 納得です。

 Vbprojectでの事前設定コードは、枠線の太さ設定に工夫すれば使えそうなので、残しておきます。

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

 まだゆきかきです。

(ichinose@一日、雪かき) 2014/02/17(月) 06:24


ichinose 様

こんばんは、nagashimaです。

「Vbprojectでの事前設定コード」で、
デザイン時のフォームに、太枠線を追加してしまうとは凄いですね。

私も触発されたことと、
まきさんが要望された「文字をHeightの中央配置 & 太枠線」のラベルが、格好良くていろいろ応用できそうなので、
実行時に太枠線を追加する方式のSubプロシージャを作ってみました。

背面に少し大き目のラベルを追加し、それが枠線に見えるようにしています。
太枠線の太さや色を実行時に指定できますが、デザイン時には実際の様子が見えないのが難点です。

サンプルを作ってみましたので、良ければ試してみてください。

1.新規ブックにて、ユーザーフォーム(UserForm1)を作成してください。

2.UserForm1に、ラベルを4個(Label1〜Label4)配置してください。

3.UserForm1のフォームモジュールに、下記のコードを貼り付けてください。

    Private Sub UserForm_Initialize()
        Dim ImgPath     As String
        Const ImgName   As String = "Dummy.bmp"        

        ImgPath = ThisWorkbook.Path & "\" & ImgName
        Label1.Picture = LoadPicture(ImgPath)
        Label2.Picture = LoadPicture(ImgPath)
        Label3.Picture = LoadPicture(ImgPath)
        Label4.Picture = LoadPicture(ImgPath)

        Label1.BackColor = &HFFFFE1
        Label2.BackColor = &HD0FFFF
        Label3.BackColor = &HE0FFE0
        Label4.BackColor = &HF0E0FF

        Call ラベルに太枠線を追加(Label1, 1# * 0.75, vbBlack)       '[*0.75]=ピクセルをポイントに変換
        Call ラベルに太枠線を追加(Label2, 2# * 0.75, vbRed)
        Call ラベルに太枠線を追加(Label3, 3# * 0.75, vbGreen)
        Call ラベルに太枠線を追加(Label4, 4# * 0.75, vbMagenta)
    End Sub

    Private Sub UserForm_Terminate()
        Call 生成したコントロールを削除(Me)
    End Sub

4.標準モジュールに、下記のコードを貼り付けてください。

    Public Sub ラベルに太枠線を追加(元ラベル As MSForms.Label, 枠太さ As Single, 枠の色 As Long)
        Dim wLbl    As MSForms.Label

        Set wLbl = 元ラベル.Parent.Controls.Add("Forms.Label.1")            '元ラベルのコンテナにラベルを追加する。
        With 元ラベル
            wLbl.Move .Left, .Top, .Width, .Height                          '追加したラベルを、元ラベルと同じ位置で同じ大きさにする。
            元ラベル.Move (.Left + 枠太さ), (.Top + 枠太さ), _
                            (.Width - 2 * 枠太さ), (.Height - 2 * 枠太さ)   '元ラベルを、指定された枠の太さ分だけ小さくする。
        End With
        元ラベル.ZOrder 0                                                   '元ラベルを、前面に表示する。
        wLbl.BackColor = 枠の色                                             '追加したラベルのBackColorを、指定された枠の色にする。
    End Sub

    Public Sub 生成したコントロールを削除(Form As MSForms.UserForm)
        Dim wCtrl As MSForms.Control

        On Error Resume Next                    '元々存在したコントロールは、エラーになるので除外する。
        For Each wCtrl In Form.Controls
            Form.Controls.Remove wCtrl.Name
        Next
        On Error GoTo 0
    End Sub

5.当ブックを一旦どこかのフォルダに保存し、
  同じフォルダにダミーの画像ファイル"Dummy.bmp"を作成してください。
  この画像ファイルは単色でさえあれば、大きさや色は任意で構いません。
  画像ファイルの名前や拡張子を変えるときは、コードの中もそれに合わせて変更してください。

6.UserForm1を実行してください。

PS
甲府辺りの道路はとんでもない渋滞になってしまったそうですね。
あさってからまた雪の予報が出ていますが、大したことがなければいいですね。

(nagashima) 2014/02/17(月) 21:40


 >単色イメージはなぜか表示されません
 これ、画像ファイルがbmpファイルの時ですね!!
 私は、GIFファイルで実験していたので意味がわからなかったのですが、
 Gifだと単色が画像が表示されます。

 通行止めで仕事がまだきちんとできません。 徐々に開通しているようですが、
 二日、三日分の仕事を一日でこなさいと・・・。

(ichinose) 2014/02/18(火) 06:20


済みません。前の発言に間違いがありました。訂正させてください。

(誤)画像ファイルは単色でさえあれば、大きさや色は任意で良い。
(正)画像ファイルは単色でさえあれば色は任意で良く、
   さらに.PicturePosition = fmPicturePositionCenterのときは、大きさも任意で良い。

1×1ピクセルの画像でテストをしていたので、
PicturePositionに何を設定しても、見た目には分らなかったのでした。

私も、gifで色々試してみました。
gifを作成するときに、透過色を指定するかどうかで、違いがあるように思えます。
 1)透過色を指定した場合は、その色がそのまま透過して表示される。
 2)透過色を指定しなかった場合は、画像の左下隅の点の色が透過して表示される。
(※ここでの透過とは、BackColorの色で表示されるという意味です。)

ichinoseさんは上記1)2)の、どちらで作成されたのでしょうか。

PS
山梨のスーパーで、3日ぶりに食料品が入荷したとのニュースが放映されていました。
返事は急ぎません。お仕事頑張ってください。

(nagashima) 2014/02/18(火) 21:15


 >どちらで作成されたのでしょうか。

 きちんとした記述をしておられるので、きちんと記述しないといけないのですが、
 申し訳ありません。

 基本的には、前回投稿した「選択されたラベルコントロールの縦のセンター配置」というプログラムを
 ちょこっと変更した結果で考察しています。

 このプログラムは、ラベルコントロールのBackcolor(パレット色)に合わせて四角形を作図し、
 これをgif画像として保存し、Loadpictureで当該ラベルコントロール反映させるものです。
 このプログラムの

               With .Chart.Rectangles.Add(0, 0, ctrl.Width, ctrl.Height)
                   .Interior.Color = ctrl.BackColor
                   .Border.Color = ctrl.BackColor
               End With

 を
               With .Chart.Rectangles.Add(0, 0, ctrl.Width, ctrl.Height)
                   .Interior.Color = vbred
                   .Border.Color = vbred
               End With

 とか、

               With .Chart.Rectangles.Add(0, 0, ctrl.Width, ctrl.Height)
                   .Interior.Color = &h8E7B91
                   .Border.Color = &h8E7B91
               End With

 等に変更して、当該ラベルコントロールのBackcolorとは関係なく、一定の色で作成した四角形を
 gif化、その後、画像ファイルをLoadpictureでラベルコントロールのPictureプロパティに設定した
 結果から、推察しています。

(ichinose) 2014/02/19(水) 05:57


ichinose 様

こんにちは、nagashimaです。

Excelの図形を.Chart.Export で画像ファイルに書き出すことができるんですね。
知りませんでした。

あれからまた調べた結果、私の推論は、
Chart.Export で書き出したGIFファイルは、「塗りつぶした色とは別の色で、透過色を指定している」らしい、
ということになりました。

(調査内容)
フリーソフト「EDGE2(体験版)」を使って、
いずれも単色の、以下の3種類の画像ファイルを作成し、
ラベルのPictureプロパティに設定するテストをしました。
 1)透過色無しの指定にする。
 2)塗りつぶした色を、透過色に指定する。
 3)塗りつぶした色とは別の色を、透過色に指定する。
結果は、
 1)および2)は、ラベルのBackColorで指定した色が表示される。
 3)は、画像ファイル作成時に塗りつぶした色が表示される。
でした。

.Chart.Exportメソッドで、「透過色の有無」や「透過色」が指定できるようになっていれば、
こんなにややこしいことは無かったのでしょうね。

(nagashima) 2014/02/19(水) 14:35


 Exportメソッドは、作成した四角形ではなく、グラグ全体をGIF化しているので記述されたような
 現象になっているのかもしれません。

 つまり、グラグ(Chrtobject)の塗りつぶしの有無や透過度等の設定でラベルコントロール
 設定に変化がでてくる可能性がでてきました。ちょこっと試した限りですが、
 >BackColorで指定した色が表示される
 という結果も得られています。これは、色に関するプロパティの設定の組合せによって
 違ってくる。という結果が得られただででも収穫です。

 又、StdPictureオブジェクトにAPIのGetClipboardData、OleCreatePictureIndirectを使って
 四角形が設定できるのでこれを SavePictureを使えば、Bmpファイル化が出来ます。
 これも四角形の作成時のプロパティの設定によって結果に違いが出てくるかもしれません。
 (現状では、BackColorで指定した色が表示されています)。

 >単色イメージはなぜか表示されません

 この問題に対し、この先の必要性の有無はわかりませんが、見た目単色の画像の表示も
 可能という事ですね。

 面白そうなので、時間が出来たらもうちょっと試してみます。

(ichinose@真央ちゃん16位かあ) 2014/02/20(木) 07:03


ichinose 様

こんばんは、nagashimaです。

Excelの.Chart.Exportメソッドで、FilenameとFilterNameの指定を変更すれば、
bmp形式およびjpg形式のファイルも出力できるようです。
例).Chart.Export ThisWorkbook.Path & "\graph.bmp", FilterName:="BMP"

それと、もしInteractive:=Trueの指定でダイアログボックスが開けば、
またいろんなことが分ると思うのですが、何故か有効になりません。

それはともかく、ichinoseさんは、画像ファイルの作成も含めて、
すべてExcelだけで実現することを目標にされておられるようですが、
私は、Excelのラベルの縦中央表示と太枠表示ができれば、
画像ファイルの作成は別のソフトで構わない、と割り切っています。

PS
雪による混乱は、落ち着いてきたのでしょうか。

(nagashima) 2014/02/20(木) 21:08


 >FilenameとFilterNameの指定を変更

 そうですね、ただ、前述したようにグラフ全体をファイル化します。作成した四角形のみを簡単にファイル化(StdPicture)できるという点で試してみました。

 >Excelのラベルの縦中央表示と太枠表示
 これも同感です。当初のVbprojectの操作でラベルの事前設定を目指していたため、
 Excelでも四角形の画像化は、できるので前述したようなコードを記述しました。
 ラベルコントロールの縦センター化が任意の単色画像ファイルひとつで実現できるなら、
 それでよいのです。
 必要ないコードですが、Vbproect操作の事前設定プログラムという私なりのテーマで投稿したので、
 コード化できるなら、全部Excelでやる
 という方針である意味練習のためExcel作成画像を使ってみました。
 いくつかの発見もありました。nagashimaさんのおかげです。
 (将来、ラベルや他のコントロール事前設定の仕様の第一歩になるかもしれないので)。

 画像に関しては、仕事(VBAで報酬の一部を得ています。
 もっとも既に仕様まででコードは人任せで私は殆ど書きませんが)では、使ったことはありませんが、
 Excelで出来ることは、Excelで挑戦してみる。これをこの学校で少し試してみる
 今回もその一環の中での投稿でした。

 雪の混乱は、少しづつ戻ってきています。私の自宅や会社の周辺は、幸い大きい被害はありませんでした。雪のため、最初は、遠くには出掛けられなかったのですが、甲府市内で、駐車場の屋根の陥没を
 3件目撃しました。中の車も大きい被害に見えました。

(ichinose@真央ちゃんの演技にうるうる) 2014/02/21(金) 05:05


ichinose 様

こんばんは、nagashimaです。

やはり全部Excelでやることを、狙っておられたのですね。
納得しました。

またの機会があれば、よろしくお願いします。

PS
天気予報で来週からようやく甲府も、最低気温が0℃以上になると言っていました。
でも今度は雪崩などにご注意くださいとも、やっかいな事ですね。
(nagashima) 2014/02/21(金) 21:26


chinose 様

こんばんは、nagashimaです。

私もすぐに自己紹介しようと思ったのですが、
折角なら、「ラベルの縦中央表示」を用いた、
「日付入力用のカレンダークラス」を見ていただきたいと思い、遅くなりました。

私は、若いときはホストコンピュータに携わっていました。
55歳から66歳の間は、ExcelVBA,VB5,Oracleを使ったアプリ開発を行いました。
そして昨年退職したとういう経歴です。

さて、「日付入力用のカレンダークラス」がほぼ出来上がりましたので、
少し長いですが、良ければ試してみてください。
尚、祝日を求める関数は、K.Tsunodaさんが作成された、ktHolidayName()を使っています。

(サンプルの概要)
TextBoxのダブルクリックすると、カレンダーが表示されます。
カレンダーの最上行にある「≪、<、>、≫」をクリックすると、それぞれ「前年、前月、翌月、翌年」が表示されます。
カレンダーの日付をダブルクリックすると、クリックした日付を元のTextBoxに書き込みます。

ここでは全てデフォルト値を使っていますが、各部の色はプロパティで変更することもできます。
 例)uCAL01.Head1_BackColor = vbYellow
プロパティには以下のものがあります。

	Baseframe	全体枠となるフレームコントロール。
	yymm	最初に表示する年月。西暦の"yyyy/mm"の形式で指定する。
	Visible	カレンダーを表示する。
	BackgroundColor	日付の存在しない部分の色。
	Head1_BackColor	年月見出し行の背景色。
	Head1_ForeColor	   〃  の文字色。
	Head2_BackColor	曜日見出し行の背景色。
	Head2_ForeColor	   〃  の月〜金曜日の文字色。
	        (※日曜日はHoliday_ForeColor、土曜日はSaturday_ForeColorになる。)
	Holiday_BackColor	日曜日と祝日の背景色。
	Holiday_ForeColor	   〃  の文字色。
	Weekday_BackColor	平日の背景色。
	Weekday_ForeColor	 〃 の文字色。
	Saturday_BackColor	土曜日の背景色。
	Saturday_ForeColor	 〃 の文字色。
	FontBold	フォントを太字にする。
	FontName	フォント名。

(手順)
1.新規ブックにて、ユーザーフォーム(UserForm1)を作成してください。

2.UserForm1に、フレームを1個(Frame1)配置してください。
  このFrame1の大きさが、カレンダーの大きさになります。

3.UserForm1に、テキストボックスを3個(TextBox1〜TextBox3)配置してください。

4.クラスモジュールを2個挿入し、1個目の名前を(uCalndr)とし、2個目の名前を(uCalndr_Child)としてください。

5.UserForm1のフォームモジュールに下記のコードを貼り付けてください。

    Option Explicit

    Private WithEvents uCAL01   As uCalndr
    Private m_TextBox           As MSForms.TextBox
    '
    Private Sub UserForm_Initialize()
        Set uCAL01 = New uCalndr
        uCAL01.Baseframe = Frame1
        uCAL01.Visible = False
        Call uCAL01.uOpen        
    End Sub
    Private Sub UserForm_Click()
        uCAL01.Visible = False      '日付入力をキャンセルしたいとき
    End Sub
    Private Sub UserForm_Terminate()
        Set uCAL01 = Nothing
    End Sub

    Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
        Cancel = True
        Set m_TextBox = TextBox1
        Call カレンダー表示位置調整(Frame1, TextBox1)
        uCAL01.Visible = True
    End Sub
    Private Sub TextBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
        Cancel = True
        Set m_TextBox = TextBox2
        Call カレンダー表示位置調整(Frame1, TextBox2)
        uCAL01.Visible = True
    End Sub
    Private Sub TextBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
        Cancel = True
        Set m_TextBox = TextBox3
        Call カレンダー表示位置調整(Frame1, TextBox3)
        uCAL01.Visible = True
    End Sub

    Private Sub カレンダー表示位置調整(ByVal Frame As MSForms.Frame, ByVal TextBox As MSForms.TextBox)
        Frame.Left = TextBox.Left
        Frame.Top = TextBox.Top + TextBox.Height

        If Frame.Top + Frame.Height > Me.Height Then
            Frame.Top = TextBox.Top - Frame.Height
        End If

        If Frame.Left + Frame.Width > Me.Width Then
            Frame.Left = Me.Width - Frame.Width - 12
        End If
    End Sub

    Private Sub uCAL01_DblClick(ByVal yymd As String)
        m_TextBox.Text = yymd
        m_TextBox.SetFocus
        Set m_TextBox = Nothing

        uCAL01.Visible = False
    End Sub

6.uCalndrのクラスモジュールに下記のコードを貼り付けてください。

    Option Explicit

    '###############################################################################################################
    '   < 日付入力用のカレンダークラス(親) >
    '###############################################################################################################

    '--- イベント生成用
    Public Event Click(ByVal yymd As String)
    Public Event DblClick(ByVal yymd As String)
    '---
    Private m_Baseframe         As MSForms.Frame        'カレンダー全体の枠となるフレーム(デザイン時に作成されているもの)
    Private m_yymm              As String               '最初に表示する年月("yyyy/mm" の形式)

    '--- 年月見出し
    Private WithEvents m_lblPreYear     As MSForms.Label    '前年
    Private WithEvents m_lblPreMonth    As MSForms.Label    '前月
    Private WithEvents m_lblyymm        As MSForms.Label    '表示中の年月
    Private WithEvents m_lblNxtMonth    As MSForms.Label    '翌月
    Private WithEvents m_lblNxtYear     As MSForms.Label    '翌年

    '--- 曜日見出し
    Private m_lblWeek(7)    As MSForms.Label

    '--- 日付ラベルのコレクション
    Private m_Childs        As Collection

    '--- 全体の背景色(日付の存在しない部分)
    Private m_BackgroundColor       As Long
    '--- 年月見出し
    Private m_Head1_BackColor       As Long
    Private m_Head1_ForeColor       As Long
    '--- 曜日見出し
    Private m_Head2_BackColor       As Long
    Private m_Head2_ForeColor       As Long     '月〜金曜日のみ(日曜日はHoliday_ForeColor、土曜日はSaturday_ForeColorになる。)
    '--- 日曜日
    Private m_Holiday_BackColor     As Long
    Private m_Holiday_ForeColor     As Long     '(ForeColorは祝日を含む)
    '--- 平日(月〜金)
    Private m_Weekday_BackColor     As Long
    Private m_Weekday_ForeColor     As Long
    '--- 土曜日
    Private m_Saturday_BackColor    As Long
    Private m_Saturday_ForeColor    As Long

    '--- 選択日付
    Private m_Sel_BackColor     As Long
    Private m_Sel_ForeColor     As Long

    '--- フォント
    Private m_FontSize          As Currency     '自動で決定される
    Private m_FontBold          As Boolean
    Private m_FontName          As String

    '--- その他のワーク
    Private m_Opend             As Boolean      'オープン済みか
    Private m_Selyymd           As String       '選択している日付(色を変更するため)
    Private m_OrgHeight         As Single       'フレームの元の高さ
    Private m_DateHeight        As Single       '日付部が6行あるときの、日付の高さ
    Private m_DateWidth         As Single       '日付の幅
    '

    Private Sub Class_Initialize()
        m_Opend = False
        Set m_Childs = New Collection
        Set m_Baseframe = Nothing

        '===== デフォルト値
        '--- 最初に表示する年月
        m_yymm = Format(Now(), "yyyy/mm")
        '--- 全体の背景
        m_BackgroundColor = &H8000000F
        '--- 年月見出し
        m_Head1_BackColor = &HE0F0E0        '(薄緑)
        m_Head1_ForeColor = vbBlack
        '--- 曜日見出し
        m_Head2_BackColor = &HA0C0A0        '(モスグリーン)
        m_Head2_ForeColor = vbWhite         '月〜金曜日のみ
        '--- 日曜日
        m_Holiday_BackColor = &HF0E1FF      '(薄桃色)
        m_Holiday_ForeColor = vbRed         ' 祝日を含む
        '--- 平日(月〜金)
        m_Weekday_BackColor = vbWhite
        m_Weekday_ForeColor = vbBlack
        '--- 土曜日
        m_Saturday_BackColor = &HFFE0E0     '(薄紫色)
        m_Saturday_ForeColor = vbBlue
        '--- 選択日付
        m_Sel_BackColor = vbBlue
        m_Sel_ForeColor = vbWhite
        ' --- フォント
        m_FontBold = False
        m_FontName = "MS ゴシック"

        m_Selyymd = ""     '最初は選択日付なし
    End Sub

    Private Sub Class_Terminate()
        '--- 自分で[uClose]を実行してもらわないと、ここは実行されない。
        '       もし[uCalndr_Child]で[myParent]を使わない方法が見つかれば、ここが自動実行される
    '    Call uClose
    End Sub

    '###########################################################################################################
    '   プロパティ(とりあえずGetプロパティはサポートしない)
    '###########################################################################################################
    Public Property Let Baseframe(ByVal NewVal As MSForms.Frame)
        If m_Baseframe Is Nothing Then
            Set m_Baseframe = NewVal
        Else
            MsgBox ("[.Baseframe]は、既に設定済みです。")
        End If
    End Property
    Public Property Let yymm(ByVal NewVal As String)
        If Len(NewVal) <> 7 Then
            MsgBox ("[.yymm]は、""yyyy/mm""の形式(7文字)で指定してください。")
            Exit Property
        End If
        If IsDate(NewVal & "/01") = False Then
            MsgBox ("[.yymm]は、""yyyy/mm""の形式(7文字)で指定してください。")
            Exit Property
        End If

        m_yymm = NewVal
    End Property

    Public Property Let Visible(ByVal NewVal As Boolean)
        m_Baseframe.Visible = NewVal
    End Property

    Public Property Let BackgroundColor(ByVal NewVal As Long)
        m_BackgroundColor = NewVal
    End Property

    '--- 年月見出し
    Public Property Let Head1_BackColor(ByVal NewVal As Long)
        m_Head1_BackColor = NewVal
        Call カレンダーの色設定
    End Property
    Public Property Let Head1_ForeColor(ByVal NewVal As Long)
        m_Head1_ForeColor = NewVal
        Call カレンダーの色設定
    End Property
    '--- 曜日見出し
    Public Property Let Head2_BackColor(ByVal NewVal As Long)
        m_Head2_BackColor = NewVal
        Call カレンダーの色設定
    End Property
    Public Property Let Head2_ForeColor(ByVal NewVal As Long)
        m_Head2_ForeColor = NewVal
        Call カレンダーの色設定
    End Property
    '--- 日曜日(ForeColorは祝日を含む)
    Public Property Let Holiday_BackColor(ByVal NewVal As Long)
        m_Holiday_BackColor = NewVal
        Call カレンダーの色設定
    End Property
    Public Property Let Holiday_ForeColor(ByVal NewVal As Long)
        m_Holiday_ForeColor = NewVal
        Call カレンダーの色設定
    End Property
    '--- 平日(月〜金)
    Public Property Let Weekday_BackColor(ByVal NewVal As Long)
        m_Weekday_BackColor = NewVal
        Call カレンダーの色設定
    End Property
    Public Property Let Weekday_ForeColor(ByVal NewVal As Long)
        m_Weekday_ForeColor = NewVal
        Call カレンダーの色設定
    End Property
    '--- 土曜日
    Public Property Let Saturday_BackColor(ByVal NewVal As Long)
        m_Saturday_BackColor = NewVal
        Call カレンダーの色設定
    End Property
    Public Property Let Saturday_ForeColor(ByVal NewVal As Long)
        m_Saturday_ForeColor = NewVal
        Call カレンダーの色設定
    End Property

    '--- フォント
    Public Property Let FontBold(ByVal NewVal As Boolean)
        m_FontBold = NewVal
    End Property
    Public Property Let FontName(ByVal NewVal As String)
        m_FontName = NewVal
    End Property

    '###########################################################################################################
    '   初期設定 & ラベルの生成
    '###########################################################################################################
    Public Function uOpen() As Boolean
        uOpen = False

        '===== 必須プロパティのチェック
        If m_Baseframe Is Nothing Then
            MsgBox ("[.Baseframe]プロパティが設定されていません。")
            Exit Function
        End If
        If m_yymm = "" Then
            MsgBox ("[.yymm]プロパティが設定されていません。")
            Exit Function
        End If

        m_FontSize = フォントサイズ決定(m_Baseframe)

        '===== 基本フレーム
        m_Baseframe.Caption = ""
        m_Baseframe.BackColor = m_BackgroundColor
        m_Baseframe.SpecialEffect = fmSpecialEffectEtched

        m_OrgHeight = m_Baseframe.Height
        m_DateHeight = m_Baseframe.InsideHeight / 8#
        m_DateWidth = m_Baseframe.InsideWidth / 7#

        '===== 年月見出しラベル、曜日見出しラベル、日付ラベル
        Call 年月見出しラベル生成
        Call 曜日見出しラベル生成
        Call 日付ラベル生成

        m_Opend = True
        Call カレンダーの色設定

        '===== 終わり
        uOpen = True

    End Function

    Public Sub uClose()
        Call 日付ラベル解放

        Set m_Childs = Nothing
        Set m_Baseframe = Nothing
    End Sub

    '***************************************************************************************
    '   (8行×7列) 文字 が入るフォントサイズを求める
    ''***************************************************************************************
    Private Function フォントサイズ決定(wFrame As MSForms.Frame) As Currency
        Dim wArray      As Variant
        Dim i           As Long
        Dim wFontSize   As Currency

        wArray = Array(6, 8, 10, 11, 12, 14, 16, 18, 20, 22, 24, 26, 28, 36)

        For i = 1 To UBound(wArray)
            wFontSize = wArray(i)
    '        If (wFontSize * 8# > wFrame.InsideHeight) Or _
    '           (wFontSize * 14# > wFrame.InsideWidth) Then      '8行 & 7列×2文字 が入るフォントサイズ
            If (wFontSize + 3) * 8# > wFrame.InsideHeight Or _
               (wFontSize + 3) * 7# > wFrame.InsideWidth Then   '(+3)= fmSpecialEffectEtched に必要な大きさ
                フォントサイズ決定 = wArray(i - 1)              '(8行×7列) 文字 が入るフォントサイズ
                Exit Function
            End If
        Next i

        フォントサイズ決定 = 36
    End Function

    Private Sub 年月見出しラベル生成()
        Set m_lblPreYear = ラベル追加(m_Baseframe, Left:=0#, Top:=0#, Width:=m_DateHeight, Height:=m_DateHeight)
        Set m_lblPreMonth = ラベル追加(m_Baseframe, Left:=Ctrl右端(m_lblPreYear), Top:=0#, Width:=m_DateHeight, Height:=m_DateHeight)
        Set m_lblyymm = ラベル追加(m_Baseframe, Left:=Ctrl右端(m_lblPreMonth), Top:=0#, Width:=m_Baseframe.InsideWidth - m_DateHeight * 4, Height:=m_DateHeight)
        Set m_lblNxtMonth = ラベル追加(m_Baseframe, Left:=Ctrl右端(m_lblyymm), Top:=0#, Width:=m_DateHeight, Height:=m_DateHeight)
        Set m_lblNxtYear = ラベル追加(m_Baseframe, Left:=Ctrl右端(m_lblNxtMonth), Top:=0#, Width:=m_DateHeight, Height:=m_DateHeight)

        m_lblPreYear.Caption = "≪"
        m_lblPreMonth.Caption = "<"
        m_lblNxtMonth.Caption = ">"
        m_lblNxtYear.Caption = "≫"
        m_lblyymm.Caption = Format(CDate(m_yymm), "yyyy年 mm月")

        m_lblPreYear.ControlTipText = "前年を表示します。"
        m_lblPreMonth.ControlTipText = "前月を表示します。"
        m_lblNxtMonth.ControlTipText = "翌月を表示します。"
        m_lblNxtYear.ControlTipText = "翌年を表示します。"
        m_lblyymm.ControlTipText = "今月を表示します。"
    End Sub
    Private Sub 曜日見出しラベル生成()
        Dim Col         As Long

        For Col = 1 To 7
            Set m_lblWeek(Col) = ラベル追加(m_Baseframe, Left:=(Col - 1) * m_DateWidth, Top:=m_DateHeight, Width:=m_DateWidth, Height:=m_DateHeight)

            Select Case Col
            Case 1:     m_lblWeek(Col).Caption = "日"
            Case 2:     m_lblWeek(Col).Caption = "月"
            Case 3:     m_lblWeek(Col).Caption = "火"
            Case 4:     m_lblWeek(Col).Caption = "水"
            Case 5:     m_lblWeek(Col).Caption = "木"
            Case 6:     m_lblWeek(Col).Caption = "金"
            Case 7:     m_lblWeek(Col).Caption = "土"
            End Select
        Next Col

    End Sub
    Private Sub 日付ラベル生成()
        Dim Row         As Long
        Dim Col         As Long
        Dim wLbl        As MSForms.Label
        Dim wChild      As uCalndr_Child
        Dim DD          As Long
        Dim wyymd       As String

        '===== 日付ラベル生成
        Row = 1
        For DD = 1 To 31        'MAX31日まで
            wyymd = m_yymm & "/" & Format(DD, "00")

            '===== あり得ない日付になったら終り
            If Not IsDate(wyymd) Then
                Exit For
            End If

            '----- 曜日を数字で取得(日曜日=1、土曜日=7)
            Col = Format(wyymd, "w")

            '----- 一日でない日曜日なら次の行へ
            If (DD > 1) And (Col = 1) Then
                Row = Row + 1     '次の行へ
            End If

            '===== 日付ラベルを生成
            Set wLbl = ラベル追加(m_Baseframe, Left:=(Col - 1) * m_DateWidth, Top:=(Row + 1#) * m_DateHeight, Width:=m_DateWidth, Height:=m_DateHeight)

            '----- 曜日・祝日による色分け(標準パレットで)
            wLbl.Caption = CStr(DD)
            Set wChild = New uCalndr_Child
            Call wChild.生成(wLbl, wyymd, Me)
            m_Childs.Add wChild, Key:=wyymd
            Set wChild = Nothing
            Set wLbl = Nothing
        Next DD

        Select Case Row
        Case 4:     m_Baseframe.Height = m_OrgHeight - m_DateHeight * 2
        Case 5:     m_Baseframe.Height = m_OrgHeight - m_DateHeight
        Case Else:  m_Baseframe.Height = m_OrgHeight
        End Select
    End Sub

    Private Sub 日付ラベル解放()
        Dim wChild      As uCalndr_Child

        '--- 生成したコントロールを[Remove]
        For Each wChild In m_Childs
            wChild.Label.Parent.Controls.Remove wChild.Label.Name
            Set wChild = Nothing
        Next wChild

        Set m_Childs = New Collection
    End Sub

    Private Function ラベル追加(Frame As MSForms.Frame, _
                                Left As Single, Top As Single, Width As Single, Height As Single) As MSForms.Label
        Dim wLbl    As MSForms.Label

        Set wLbl = Frame.Controls.Add("Forms.Label.1")
        wLbl.SpecialEffect = fmSpecialEffectEtched
        wLbl.PicturePosition = fmPicturePositionCenter
        wLbl.Picture = LoadPicture(ThisWorkbook.Path & "\Dummy.bmp")
        wLbl.Move Left, Top, Width, Height

        wLbl.Font.Size = m_FontSize
        wLbl.Font.Name = m_FontName
        wLbl.Font.Bold = m_FontBold

        Set ラベル追加 = wLbl
        Set wLbl = Nothing
    End Function

    Private Sub m_lblyymm_Click()
        Call 指定年月を表示(Format(Now(), "yyyy/mm"))       '今月を表示
    End Sub
    Private Sub m_lblPreYear_Click()
        Call 表示月を変更(-12)  '12ヶ月前
    End Sub
    Private Sub m_lblPreMonth_Click()
        Call 表示月を変更(-1)   '1ヶ月前
    End Sub
    Private Sub m_lblNxtMonth_Click()
        Call 表示月を変更(1)    '1ヶ月後
    End Sub
    Private Sub m_lblNxtYear_Click()
        Call 表示月を変更(12)   '12ヶ月後
    End Sub
    Private Sub 表示月を変更(AddMonth As Long)
        Dim wyymd   As String

        wyymd = DateAdd("m", AddMonth, m_yymm)
        Call 指定年月を表示(Format(wyymd, "yyyy/mm"))       '今月を表示
    End Sub
    Private Sub 指定年月を表示(yymm As String)
        Call 日付ラベル解放

        m_Selyymd = ""          '選択日付クリア(戻し処理が不要)
        m_yymm = yymm
        Call 日付ラベル生成
        Call カレンダーの色設定

        m_lblyymm.Caption = Format(CDate(m_yymm), "yyyy年mm月")
    End Sub

    Private Sub カレンダーの色設定()
        Dim Col         As Long
        Dim wChild      As uCalndr_Child

        If m_Opend = True Then      '年月見出しラベルが、まだ生成されていないので
            '--- 年月見出しラベル
            m_lblPreYear.BackColor = m_Head1_BackColor
            m_lblPreMonth.BackColor = m_Head1_BackColor
            m_lblyymm.BackColor = m_Head1_BackColor
            m_lblNxtMonth.BackColor = m_Head1_BackColor
            m_lblNxtYear.BackColor = m_Head1_BackColor
            m_lblPreYear.ForeColor = m_Head1_ForeColor
            m_lblPreMonth.ForeColor = m_Head1_ForeColor
            m_lblyymm.ForeColor = m_Head1_ForeColor
            m_lblNxtMonth.ForeColor = m_Head1_ForeColor
            m_lblNxtYear.ForeColor = m_Head1_ForeColor

            '--- 曜日見出しラベル
            For Col = 1 To 7
                m_lblWeek(Col).BackColor = m_Head2_BackColor

                Select Case Col
                Case 1:     m_lblWeek(Col).ForeColor = m_Holiday_ForeColor
                Case 7:     m_lblWeek(Col).ForeColor = m_Saturday_ForeColor
                Case Else:  m_lblWeek(Col).ForeColor = m_Head2_ForeColor
                End Select
            Next Col

            '--- 日付ラベル
            For Each wChild In m_Childs
                Call 日付ラベルの色設定(wChild)
            Next wChild

            Set wChild = Nothing
        End If
    End Sub
    Private Sub 日付ラベルの色設定(wChild As uCalndr_Child)
        Dim wWeekNo     As Long
        Dim 祝日        As String

        wWeekNo = Format(wChild.yymd, "w")

        '--- 背景色
        Select Case wWeekNo
        Case 1:         wChild.Label.BackColor = m_Holiday_BackColor
        Case 2 To 6:    wChild.Label.BackColor = m_Weekday_BackColor
        Case 7:         wChild.Label.BackColor = m_Saturday_BackColor
        End Select

        '--- 文字色
        Select Case wWeekNo
        Case 1:     wChild.Label.ForeColor = m_Holiday_ForeColor      '日曜
        Case 7:     wChild.Label.ForeColor = m_Saturday_ForeColor     '土曜
        Case Else:  wChild.Label.ForeColor = m_Weekday_ForeColor      '平日
        End Select

        祝日 = ktHolidayName(wChild.yymd)
        If 祝日 <> "" Then
            wChild.Label.ForeColor = m_Holiday_ForeColor      '祝日
        End If
    End Sub

    '###############################################################################################################
    '   子クラスのイベントから呼ばれる関数
    '###############################################################################################################
    Public Sub 内部関数_Relay_Click(ByVal yymd As String)

        '--- 以前に選択されていた日付の色を元に戻す
        If m_Selyymd <> "" Then
            Call 日付ラベルの色設定(m_Childs(m_Selyymd))
        End If
        '--- 選択された日付を色分け
        m_Childs(yymd).Label.BackColor = m_Sel_BackColor
        m_Childs(yymd).Label.ForeColor = m_Sel_ForeColor
        m_Selyymd = yymd

        RaiseEvent Click(yymd)
    End Sub
    Public Sub 内部関数_Relay_DblClick(ByVal yymd As String)
        RaiseEvent DblClick(yymd)
    End Sub

    Private Function Ctrl右端(Ctrl As MSForms.Control) As Single
        Ctrl右端 = Ctrl.Left + Ctrl.Width
    End Function

    '###############################################################################################################
    '   祝日を求める関数
    '###############################################################################################################
    '## 別参考)http://www.moug.net/tech/exvba/0130006.htm?PRINT

    '## http://www.h3.dion.ne.jp/~sakatsu/holiday_logic.htm#VBA
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
    '_/
    '_/ CopyRight(C) K.Tsunoda(AddinBox) 2001 All Rights Reserved.
    '_/ ( http://www.h3.dion.ne.jp/~sakatsu/index.htm )
    '_/
    '_/  この祝日マクロは『kt関数アドイン』で使用しているものです。
    '_/  このロジックは、レスポンスを第一義として、可能な限り少ない
    '_/   【条件判定の実行】で結果を出せるように設計してあります。
    '_/  この関数では、2007年施行の改正祝日法(昭和の日)までを
    '_/   サポートしています(9月の国民の休日を含む)。
    '_/
    '_/ (*1)このマクロを引用するに当たっては、必ずこのコメントも
    '_/   一緒に引用する事とします。
    '_/ (*2)他サイト上で本マクロを直接引用する事は、ご遠慮願います。
    '_/   【 http://www.h3.dion.ne.jp/~sakatsu/holiday_logic.htm 】
    '_/   へのリンクによる紹介で対応して下さい。
    '_/ (*3)[ktHolidayName]という関数名そのものは、各自の環境に
    '_/   おける命名規則に沿って変更しても構いません。
    '_/
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

    Public Function ktHolidayName(ByVal 日付 As Date) As String
        Dim dtm日付     As Date
        Dim str祝日名   As String
        Const cst振替休日施行日 As Date = "1973/4/12"

    '時刻/時刻誤差の削除(Now関数などへの対応)
        dtm日付 = DateSerial(Year(日付), Month(日付), Day(日付))
        'シリアル値は[±0.5秒]の誤差範囲で認識されます。2002/6/21はシリアル値で
        '[37428.0]ですが、これに[-0.5秒]の誤差が入れば[37427.9999942130]となり、
        'Int関数で整数部分を取り出せば[37427]で前日日付になってしまいます。
        '※ 但し、引数に指定する値が必ず【手入力した日付】等で、時刻や時刻誤差を
        '  考慮しなくても良いならば、このステップは不要です。引数[日付]をそのまま
        '  使用しても問題ありません(ほとんどの利用形態ではこちらでしょうが‥‥)。

        str祝日名 = prv祝日(dtm日付)
        If (str祝日名 = "") Then
            If (Weekday(dtm日付) = vbMonday) Then
                ' 月曜以外は振替休日判定不要
                ' 5/6(火,水)の判定は[prv祝日]で処理済
                ' 5/6(月)はここで判定する
                If (dtm日付 >= cst振替休日施行日) Then
                    str祝日名 = prv祝日(dtm日付 - 1)
                    If (str祝日名 <> "") Then
                        ktHolidayName = "振替休日"
                    Else
                        ktHolidayName = ""
                    End If
                Else
                    ktHolidayName = ""
                End If
            Else
                ktHolidayName = ""
            End If
        Else
            ktHolidayName = str祝日名
        End If
    End Function

    '========================================================================
    Private Function prv祝日(ByVal 日付 As Date) As String
        Dim int年       As Integer
        Dim int月       As Integer
        Dim int日       As Integer
        Dim int秋分日   As Integer
        Dim str第N曜日  As String
        ' 時刻データ(小数部)は取り除いてあるので、下記の日付との比較はOK
        Const cst祝日法施行 As Date = "1948/7/20"
        Const cst昭和天皇の大喪の礼 As Date = "1989/2/24"
        Const cst明仁親王の結婚の儀 As Date = "1959/4/10"
        Const cst徳仁親王の結婚の儀 As Date = "1993/6/9"
        Const cst即位礼正殿の儀 As Date = "1990/11/12"

        int年 = Year(日付)
        int月 = Month(日付)
        int日 = Day(日付)

        prv祝日 = ""
        If (日付 < cst祝日法施行) Then
            Exit Function    ' 祝日法施行以前
        End If

        Select Case int月
        Case 1
            If (int日 = 1) Then
                prv祝日 = "元日"
            Else
                If (int年 >= 2000) Then
                    str第N曜日 = (((int日 - 1) \ 7) + 1) & Weekday(日付)
                    If (str第N曜日 = "22") Then  'Monday:2
                        prv祝日 = "成人の日"
                    End If
                Else
                    If (int日 = 15) Then
                        prv祝日 = "成人の日"
                    End If
                End If
            End If
        Case 2
            If (int日 = 11) Then
                If (int年 >= 1967) Then
                    prv祝日 = "建国記念の日"
                End If
            ElseIf (日付 = cst昭和天皇の大喪の礼) Then
                prv祝日 = "昭和天皇の大喪の礼"
            End If
        Case 3
            If (int日 = prv春分日(int年)) Then  ' 1948〜2150以外は[99]
                prv祝日 = "春分の日"            ' が返るので、必ず≠になる
            End If
        Case 4
            If (int日 = 29) Then
                If (int年 >= 2007) Then
                    prv祝日 = "昭和の日"
                ElseIf (int年 >= 1989) Then
                    prv祝日 = "みどりの日"
                Else
                    prv祝日 = "天皇誕生日"
                End If
            ElseIf (日付 = cst明仁親王の結婚の儀) Then
                prv祝日 = "皇太子明仁親王の結婚の儀"
            End If
        Case 5
            If (int日 = 3) Then
                prv祝日 = "憲法記念日"
            ElseIf (int日 = 4) Then
                If (int年 >= 2007) Then
                    prv祝日 = "みどりの日"
                ElseIf (int年 >= 1986) Then
                    ' 5/4が日曜日は『只の日曜』、月曜日は『憲法記念日の振替休日』(〜2006年)
                    If (Weekday(日付) > vbMonday) Then
                        prv祝日 = "国民の休日"
                    End If
                End If
            ElseIf (int日 = 5) Then
                prv祝日 = "こどもの日"
            ElseIf (int日 = 6) Then
                If (int年 >= 2007) Then
                    Select Case Weekday(日付)
                        Case vbTuesday, vbWednesday
                            prv祝日 = "振替休日"    ' [5/3,5/4が日曜]ケースのみ、ここで判定
                    End Select
                End If
            End If
        Case 6
            If (日付 = cst徳仁親王の結婚の儀) Then
                prv祝日 = "皇太子徳仁親王の結婚の儀"
            End If
        Case 7
            If (int年 >= 2003) Then
                str第N曜日 = (((int日 - 1) \ 7) + 1) & Weekday(日付)
                If (str第N曜日 = "32") Then  'Monday:2
                    prv祝日 = "海の日"
                End If
            ElseIf (int年 >= 1996) Then
                If (int日 = 20) Then
                    prv祝日 = "海の日"
                End If
            End If
        Case 9
            '第3月曜日(15〜21)と秋分日(22〜24)が重なる事はない
            int秋分日 = prv秋分日(int年)
            If (int日 = int秋分日) Then  ' 1948〜2150以外は[99]
                prv祝日 = "秋分の日"      ' が返るので、必ず≠になる
            Else
                If (int年 >= 2003) Then
                    str第N曜日 = (((int日 - 1) \ 7) + 1) & Weekday(日付)
                    If (str第N曜日 = "32") Then  'Monday:2
                        prv祝日 = "敬老の日"
                    ElseIf (Weekday(日付) = vbTuesday) Then
                        If (int日 = (int秋分日 - 1)) Then
                            prv祝日 = "国民の休日"
                        End If
                    End If
                ElseIf (int年 >= 1966) Then
                    If (int日 = 15) Then
                        prv祝日 = "敬老の日"
                    End If
                End If
            End If
        Case 10
            If (int年 >= 2000) Then
                str第N曜日 = (((int日 - 1) \ 7) + 1) & Weekday(日付)
                If (str第N曜日 = "22") Then  'Monday:2
                    prv祝日 = "体育の日"
                End If
            ElseIf (int年 >= 1966) Then
                If (int日 = 10) Then
                    prv祝日 = "体育の日"
                End If
            End If
        Case 11
            If (int日 = 3) Then
                prv祝日 = "文化の日"
            ElseIf (int日 = 23) Then
                prv祝日 = "勤労感謝の日"
            ElseIf (日付 = cst即位礼正殿の儀) Then
                prv祝日 = "即位礼正殿の儀"
            End If
        Case 12
            If (int日 = 23) Then
                If (int年 >= 1989) Then
                    prv祝日 = "天皇誕生日"
                End If
            End If
        End Select
    End Function

    '======================================================================
    ' 春分/秋分日の略算式は
    '  『海上保安庁水路部 暦計算研究会編 新こよみ便利帳』
    ' で紹介されている式です。
    Private Function prv春分日(ByVal 年 As Integer) As Integer
        If (年 <= 1947) Then
            prv春分日 = 99        '祝日法施行前
        ElseIf (年 <= 1979) Then
            '(年 - 1983)がマイナスになるので『Fix関数』にする
            prv春分日 = Fix(20.8357 + (0.242194 * (年 - 1980)) - Fix((年 - 1983) / 4))
        ElseIf (年 <= 2099) Then
            prv春分日 = Fix(20.8431 + (0.242194 * (年 - 1980)) - Fix((年 - 1980) / 4))
        ElseIf (年 <= 2150) Then
            prv春分日 = Fix(21.851 + (0.242194 * (年 - 1980)) - Fix((年 - 1980) / 4))
        Else
            prv春分日 = 99        '2151年以降は略算式が無いので不明
        End If
    End Function

    '========================================================================
    Private Function prv秋分日(ByVal 年 As Integer) As Integer
        If (年 <= 1947) Then
            prv秋分日 = 99        '祝日法施行前
        ElseIf (年 <= 1979) Then
            '(年 - 1983)がマイナスになるので『Fix関数』にする
            prv秋分日 = Fix(23.2588 + (0.242194 * (年 - 1980)) - Fix((年 - 1983) / 4))
        ElseIf (年 <= 2099) Then
            prv秋分日 = Fix(23.2488 + (0.242194 * (年 - 1980)) - Fix((年 - 1980) / 4))
        ElseIf (年 <= 2150) Then
            prv秋分日 = Fix(24.2488 + (0.242194 * (年 - 1980)) - Fix((年 - 1980) / 4))
        Else
            prv秋分日 = 99        '2151年以降は略算式が無いので不明
        End If
    End Function

    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
    '_/ CopyRight(C) K.Tsunoda(AddinBox) 2001 All Rights Reserved.
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

7.uCalndr_Childのクラスモジュールに下記のコードを貼り付けてください。

    Option Explicit

    '###############################################################################################################
    '   < 日付入力用のカレンダークラス(子) >
    '###############################################################################################################

    Private m_Parent                As uCalndr
    Private WithEvents m_Label      As MSForms.Label
    Private m_yymd      As String   '日付("yyyy/mm/dd"形式の年月日)
    '

    Private Sub Class_Initialize()
    '
    End Sub
    Private Sub Class_Terminate()
        Set m_Label = Nothing
        Set m_Parent = Nothing
    End Sub

    '##########################################################################
    '   メソッド
    '##########################################################################
    Public Sub 生成(NewVal As MSForms.Label, yymd As String, wParent As uCalndr)
        Set m_Label = NewVal
        Set m_Parent = wParent
        m_yymd = yymd
    End Sub

    '##########################################################################
    '   プロパティ
    '##########################################################################
    Public Property Get Label() As MSForms.Label
        Set Label = m_Label
    End Property
    Public Property Get yymd() As String
        yymd = m_yymd
    End Property

    '##########################################################################
    '   イベント
    '##########################################################################
    Private Sub m_Label_Click()
        Call m_Parent.内部関数_Relay_Click(m_yymd)
    End Sub
    Private Sub m_Label_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
        Cancel = True       '##### これが大事 #####
        Call m_Parent.内部関数_Relay_DblClick(m_yymd)
    End Sub

8.当ブックを一旦どこかのフォルダに保存し、
  同じフォルダに単色の画像ファイル"Dummy.bmp"を作成してください。
  画像ファイルの名前や拡張子を変えるときは、コードの中もそれに合わせて変更してください。

9.UserForm1を実行してください。

(nagashima) 2014/02/25(火) 23:32


 コードを実行してみました。

 便利ですねえ。これがあれば、カレンダーコントロールのアクセスの所有物だから どうのこうの
 なんてこと気にせずにカレンダーが使えそうですね!!

 便利なのでクラスは、別アドイン等で利用するような完全カプセル化で運用できると良いですね

 >55歳から66歳の間は、ExcelVBA,VB5,Oracleを使ったアプリ開発を行いました。 
 >そして昨年退職したとういう経歴です。 

 私は、今年その55歳になります。
 大先輩ですね!!

(ichinose) 2014/03/02(日) 21:13


ichinose 様

こんにちは、nagashimaです。

クラスは、別アドイン等で利用するような完全カプセル化で運用できると良いですね

なるほどいいアイデアですね。
参照設定さえ問題なければできそうですね。
機会を見てトライしてみます。
(nagashima) 2014/03/03(月) 11:24


chinose 様

こんばんは、nagashimaです。

 >クラスは、別アドイン等で利用するような完全カプセル化で運用できると良いですね 
カレンダークラスをアドインで利用するカプセル化が、
ほぼ出来たようなので報告します。
良ければ試してみてください。

(概要)
前回のサンプルのうち、2個のクラス部分をアドイン側とし、
ユーザフォーム部分をアドインを使用する側として、
二つのブックに分けます。

但し、アドインを使用する側からは、Newキーワードで、
直接クラスのインスタンスを作ることが出来ないので、
アドイン側に「クラスのインスタンスを作って、それを返す」関数を用意し、
アドインを使用する側から呼んでもらいます。

(手順)
1.「カレンダークラス.xlsx」を作成し、以下のようにします。

 1−1)標準モジュールを1個作成し、下記のコードを貼り付けます。

	Public Function Create_uCalndr() As uCalndr
	    Set Create_uCalndr = New uCalndr
	End Function

 1−2)クラスモジュール「uCalndr」と「uCalndr_Child」を作成し、
     前回と同じコードを貼り付けます。

 1−3)クラスモジュール「uCalndr」のプロパティで、InstancingをPublicNoCreatableに設定します。

 1−4)ツール ⇒ 参照設定で、「Microsoft Forms2.0 Object Library」にチェックを入れ、参照します。
     (※参照設定画面に表示されない場合は、一旦ユーザフォームを挿入してから削除します。)

 1−5)ツール ⇒ VBAProject のプロパティ ⇒ 「全般」タブ ⇒ プロジェクト名を、「カレンダークラス」に変更します。
     (※他のプロジェクトから参照設定されるときに、名前をユニークにするため。)

 1−6)コードを見られたくないときは、
     ツール ⇒ VBAProject のプロパティ ⇒ 「保護」タブ で、
     「プロジェクトを表示用にロックする」にチェックを入れ、パスワードを設定します。

 1−7)当ブックを一旦保存しておいてから、
     名前を付けて保存 ⇒ その他の形式 ⇒ Excel アドイン(*.xlma)で、「カレンダークラス.xlam」を保存し、閉じます。

 1−8)前回と同様に、「カレンダークラス.xlam」を保存したフォルダと同じフォルダに、
     単色の画像ファイル"Dummy.bmp"を作成してください。

2.Excelを起動し直したのち、
  Excel のオプション ⇒ アドイン ⇒ 「設定」ボタン ⇒ アドイン画面で、
  「カレンダークラス」にチェックを入れ、アドインを登録し、
  再度Excelを起動し直します。

3.「カレンダーテスト.xlsx」を作成し、以下のようにします。

 3−1)ユーザーフォーム(UserForm1)を作成し、前回と同様に、
     フレームを1個(Frame1)と、テキストボックスを3個(TextBox1〜TextBox3)配置します。

 3−2)UserForm1のフォームモジュールに、前回と同じコードを貼り付けたのち、

    Set uCAL01 = New uCalndr を
    Set uCAL01 = カレンダークラス.Create_uCalndr に変更します。

 3−3)ツール ⇒ 参照設定で、「カレンダーテスト」にチェックを入れ、参照します。

 3−4)UserForm1を実行してください。
(nagashima) 2014/03/06(木) 18:42


 PublicNotCreatableとインスタンスを返す関数さえあれば良さそうでしたので、
 記述したのですが、元のクラスの設計が良いからですね!!

 カレンダーって、祝日の定義の変更や増加のことを考えると、メンテナンスが厄介ですねえ
 カレンダーコントロールを仕事では、一度しか使ったことがないのですが、
 今回コードを拝見して、このコントロールのメンテは大変だなあ
 と感じました。
 Ofiice2010には、カレンダーコントロールがサポートされていないということも
 提示されたコードをテストさせていただいている過程で知りました。

 提示されたカレンダークラスは、大変便利ですね!!アドイン化してあれば、ユーザーは、
 インターフェースだけ知っていれば、良いのですから、使いかってもよさそうです!!

 Valueプロパティ(日付の取得と設定)定義やbmpファイルの自動生成等、
 あればさらに便利なんて思いましたが、
 土台のよいメンテしやすいコードの提示をされたので、
 これはそれぞれで工夫し、追加すればよいですね。
 そもそもがラベルの縦方向のセンター配置のパーフォーマンスコードを投稿された
 と思うのでこれ以上は申し上げることはないのです・・・・。

 お疲れ様でした。

(ichinose) 2014/03/09(日) 10:16


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.