[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ユーザーフォームのラベル文字をHeightの中央配置』（まき）
Excel2003,Vista
いつも色々参考にさせて頂いております。
検索したつもりですが、見当たりませんでしたので質問させて頂きます。 ユーザーフォーム上でラベルを配置しheightを大きくし、この中央に文字を配置したい と考えています。この時にBoderStyle:1としています。シートのセルで言う配置、縦位 置、中央揃えで外周を線で囲いたいのを行いたいです。ラベルを２個重ねれば出来るの ですが、少し芸が無い様に思えたので質問させて頂きました。 ラベルのプロパティに同設定が無いので（多分）、上記の様にラベルを２つ重ねないと 出来ないのでしょうか。
以上よろしくお願い申し上げます。
>少し芸が無い様に思えたので質問させて頂きました。 >上記の様にラベルを２つ重ねないと出来ないのでしょうか。 芸がないとは思いませんが、この方法しかなさそうですねえ！！ Vbprojectを操作してこの二つのラベルを重ねて、 きれいに縦方向のセンタリングを自動化するVBAを 作成することを考えるのはどうですか？ 芸があると思いますよ！！
ichinose
ご回答頂き有り難うございました。
やっぱりセルの様に出来ない見たいなので、２つのラベルを重ねる様に致します。本当は、枠の線の太 さも位置により変えたかったのですが。。。もう少しユーザーフォームに線等の使える物が欲しいです。。
以上よろしくお願い申し上げます。
>本当は、枠の線の太さも位置により変えたかったのですが
これは、ラベルを細い線して代用する方法が考えられます。
新規ブックにて、ユーザーフォーム（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様のサンプルを動かしてみました。言われた通りの３個の枠が太さ違いで描画されてい ます。私のレベルでは、マクロで描画する事が出来ません。今回のサンプルを勉強させて頂き、私の今 作成しているフォームに反映出来る様試してみます。
正直びっくりでした。。。。凄いです。
有り難うございました。
これで、Caption指定文字はラベル中央に表示されます。
※単色イメージが反映されない理由が判らない。
（KobayashiCttn） 2014/02/01(土) 17:52
私も「ラベルの縦中央配置」でずっと苦しんでいました。
こんな方法があったとは知りませんでした。
教えて頂いてとても嬉しいです。
私も色々試してみたところ、
「単色イメージが反映されない」現象が少しだけ詳しくわかりました。
Pictureプロパティを持つコントロールが、
LoadPictureで画像を読むとき、読み方に２種類があるようです。
（Ａグループ)Image、Page、Frame
… 画像ををのまま表示する。
（Ｂグループ)Label、CommandButton、ToggleButton、OptionButton、CheckBox
… 画像の左下隅にある色は、BackColorの色で表示する。
尚、私のＰＣ環境は Windows8.1 + Excel2007 です。
（nagashima） 2014/02/07(金) 12:07
>PicturePositionを12-fmPicturePositionCenterを指定。 本当ですね！！ 知りませんでした。情報、ありがとうございます。
>単色イメージはなぜか表示されません の意味がわかりませんでしたが、Excelで作図する塗りつぶし四角形をこのラベルのPictuteに 設定すると単色背景色は設定できそうですね！！
手動操作では、
・ ラベルコントロールに合わせたサイズの四角形を作成する。これをコピー
・ VBEにて、当該ラベルコントロールを選択する。
・ Ｆ４キーを押して表示されるプロパティ一覧を表示させ、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
こんばんは、nagashimaです。
私は「単色イメージはなぜか表示されません」の価値は、
コードでBackColorプロパティの値を変更することにより、
実行時に任意の背景色を設定できることにあるように思いました。
＜応用例１＞
Captionで指定した文字列をそのまま表示させる場合は、
Paintソフトなどで作成した、１×１ピクセルの大きさの画像ファイルを、Pictureプロパティに設定すれば、
文字列の位置をPicturePositionプロパティで設定できるし、
BackColorプロパティもそのまま有効になる。
＜応用例２＞
フラットなボタンの代用として、ラベルを使う場合に、
例えば下図のようなボタンイメージを作るとして（「進むボタン」とかでよくあるやつです）、
三角の内側を黒色とし、三角の外側を白色とした画像をファイルを、Pictureプロパティに設定すれば、
外側の白色の部分は、画像の左下隅にある色なので、BackColorプロパティで任意の色に変更できる。
（※Caption=""としています。）
−−−−−−− ｜ ｜ ｜ ｜＼ ｜ ｜ ｜ ＼ ｜ ｜ ｜ ／ ｜ ｜ ｜／ ｜ ｜ ｜ −−−−−−−
ＰＳ
京都です。雨で雪もほとんど消えてしまいました。2/15 22：17。
（nagashima） 2014/02/15(土) 22:24
透明の小さい四角形で確認しました。これだと、小さい画像だけ用意すれば、コードは要りませんね。 納得です。
Vbprojectでの事前設定コードは、枠線の太さ設定に工夫すれば使えそうなので、残しておきます。
ありがとうございました。
まだゆきかきです。
（ichinose@一日、雪かき） 2014/02/17(月) 06:24
こんばんは、nagashimaです。
「Vbprojectでの事前設定コード」で、
デザイン時のフォームに、太枠線を追加してしまうとは凄いですね。
私も触発されたことと、
まきさんが要望された「文字をHeightの中央配置 ＆ 太枠線」のラベルが、格好良くていろいろ応用できそうなので、
実行時に太枠線を追加する方式のSubプロシージャを作ってみました。
背面に少し大き目のラベルを追加し、それが枠線に見えるようにしています。
太枠線の太さや色を実行時に指定できますが、デザイン時には実際の様子が見えないのが難点です。
サンプルを作ってみましたので、良ければ試してみてください。
１．新規ブックにて、ユーザーフォーム（UserForm1）を作成してください。
２．UserForm1に、ラベルを４個（Label1〜Label4）配置してください。
３．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
４．標準モジュールに、下記のコードを貼り付けてください。
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
５．当ブックを一旦どこかのフォルダに保存し、
同じフォルダにダミーの画像ファイル"Dummy.bmp"を作成してください。
この画像ファイルは単色でさえあれば、大きさや色は任意で構いません。
画像ファイルの名前や拡張子を変えるときは、コードの中もそれに合わせて変更してください。
６．UserForm1を実行してください。
ＰＳ
甲府辺りの道路はとんでもない渋滞になってしまったそうですね。
あさってからまた雪の予報が出ていますが、大したことがなければいいですね。
（nagashima） 2014/02/17(月) 21:40
>単色イメージはなぜか表示されません これ、画像ファイルがbmpファイルの時ですね！！ 私は、GIFファイルで実験していたので意味がわからなかったのですが、 Gifだと単色が画像が表示されます。
通行止めで仕事がまだきちんとできません。 徐々に開通しているようですが、 二日、三日分の仕事を一日でこなさいと・・・。
（ichinose） 2014/02/18(火) 06:20
（誤）画像ファイルは単色でさえあれば、大きさや色は任意で良い。
（正）画像ファイルは単色でさえあれば色は任意で良く、
さらに.PicturePosition = fmPicturePositionCenterのときは、大きさも任意で良い。
１×１ピクセルの画像でテストをしていたので、
PicturePositionに何を設定しても、見た目には分らなかったのでした。
私も、gifで色々試してみました。
gifを作成するときに、透過色を指定するかどうかで、違いがあるように思えます。
１）透過色を指定した場合は、その色がそのまま透過して表示される。
２）透過色を指定しなかった場合は、画像の左下隅の点の色が透過して表示される。
（※ここでの透過とは、BackColorの色で表示されるという意味です。）
ichinoseさんは上記１）２）の、どちらで作成されたのでしょうか。
ＰＳ
山梨のスーパーで、３日ぶりに食料品が入荷したとのニュースが放映されていました。
返事は急ぎません。お仕事頑張ってください。
（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
こんにちは、nagashimaです。
Excelの図形を.Chart.Export で画像ファイルに書き出すことができるんですね。
知りませんでした。
あれからまた調べた結果、私の推論は、
Chart.Export で書き出したGIFファイルは、「塗りつぶした色とは別の色で、透過色を指定している」らしい、
ということになりました。
（調査内容）
フリーソフト「EDGE2（体験版）」を使って、
いずれも単色の、以下の３種類の画像ファイルを作成し、
ラベルのPictureプロパティに設定するテストをしました。
１）透過色無しの指定にする。
２）塗りつぶした色を、透過色に指定する。
３）塗りつぶした色とは別の色を、透過色に指定する。
結果は、
１）および２）は、ラベルのBackColorで指定した色が表示される。
３）は、画像ファイル作成時に塗りつぶした色が表示される。
でした。
.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
こんばんは、nagashimaです。
Excelの.Chart.Exportメソッドで、FilenameとFilterNameの指定を変更すれば、
bmp形式およびjpg形式のファイルも出力できるようです。
例）.Chart.Export ThisWorkbook.Path & "\graph.bmp", FilterName:="BMP"
それと、もしInteractive:=Trueの指定でダイアログボックスが開けば、
またいろんなことが分ると思うのですが、何故か有効になりません。
それはともかく、ichinoseさんは、画像ファイルの作成も含めて、
すべてExcelだけで実現することを目標にされておられるようですが、
私は、Excelのラベルの縦中央表示と太枠表示ができれば、
画像ファイルの作成は別のソフトで構わない、と割り切っています。
ＰＳ
雪による混乱は、落ち着いてきたのでしょうか。
（nagashima） 2014/02/20(木) 21:08
>FilenameとFilterNameの指定を変更
そうですね、ただ、前述したようにグラフ全体をファイル化します。作成した四角形のみを簡単にファイル化（StdPicture）できるという点で試してみました。
>Excelのラベルの縦中央表示と太枠表示 これも同感です。当初のVbprojectの操作でラベルの事前設定を目指していたため、 Excelでも四角形の画像化は、できるので前述したようなコードを記述しました。 ラベルコントロールの縦センター化が任意の単色画像ファイルひとつで実現できるなら、 それでよいのです。 必要ないコードですが、Vbproect操作の事前設定プログラムという私なりのテーマで投稿したので、 コード化できるなら、全部Excelでやる という方針である意味練習のためExcel作成画像を使ってみました。 いくつかの発見もありました。nagashimaさんのおかげです。 (将来、ラベルや他のコントロール事前設定の仕様の第一歩になるかもしれないので）。
画像に関しては、仕事（VBAで報酬の一部を得ています。 もっとも既に仕様まででコードは人任せで私は殆ど書きませんが）では、使ったことはありませんが、 Excelで出来ることは、Excelで挑戦してみる。これをこの学校で少し試してみる 今回もその一環の中での投稿でした。
雪の混乱は、少しづつ戻ってきています。私の自宅や会社の周辺は、幸い大きい被害はありませんでした。雪のため、最初は、遠くには出掛けられなかったのですが、甲府市内で、駐車場の屋根の陥没を ３件目撃しました。中の車も大きい被害に見えました。
（ichinose@真央ちゃんの演技にうるうる） 2014/02/21(金) 05:05
こんばんは、nagashimaです。
やはり全部Excelでやることを、狙っておられたのですね。
納得しました。
またの機会があれば、よろしくお願いします。
ＰＳ
天気予報で来週からようやく甲府も、最低気温が０℃以上になると言っていました。
でも今度は雪崩などにご注意くださいとも、やっかいな事ですね。
（nagashima） 2014/02/21(金) 21:26
こんばんは、nagashimaです。
私もすぐに自己紹介しようと思ったのですが、
折角なら、「ラベルの縦中央表示」を用いた、
「日付入力用のカレンダークラス」を見ていただきたいと思い、遅くなりました。
私は、若いときはホストコンピュータに携わっていました。
５５歳から６６歳の間は、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 フォント名。
（手順）
１．新規ブックにて、ユーザーフォーム（UserForm1）を作成してください。
２．UserForm1に、フレームを１個（Frame1）配置してください。
このFrame1の大きさが、カレンダーの大きさになります。
３．UserForm1に、テキストボックスを３個（TextBox1〜TextBox3）配置してください。
４．クラスモジュールを２個挿入し、１個目の名前を（uCalndr）とし、２個目の名前を（uCalndr_Child）としてください。
５．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
６．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 '日付部が６行あるときの、日付の高さ
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 = "ＭＳ ゴシック"
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""の形式（７文字）で指定してください。")
Exit Property
End If
If IsDate(NewVal & "/01") = False Then
MsgBox ("[.yymm]は、""yyyy/mm""の形式（７文字）で指定してください。")
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
'***************************************************************************************
' (８行×７列) 文字 が入るフォントサイズを求める
''***************************************************************************************
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 '８行 ＆ ７列×２文字 が入るフォントサイズ
If (wFontSize + 3) * 8# > wFrame.InsideHeight Or _
(wFontSize + 3) * 7# > wFrame.InsideWidth Then '(+3)= fmSpecialEffectEtched に必要な大きさ
フォントサイズ決定 = wArray(i - 1) '(８行×７列) 文字 が入るフォントサイズ
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 'MAX３１日まで
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) '１２ヶ月前
End Sub
Private Sub m_lblPreMonth_Click()
Call 表示月を変更(-1) '１ヶ月前
End Sub
Private Sub m_lblNxtMonth_Click()
Call 表示月を変更(1) '１ヶ月後
End Sub
Private Sub m_lblNxtYear_Click()
Call 表示月を変更(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関数アドイン』で使用しているものです。
'_/ このロジックは、レスポンスを第一義として、可能な限り少ない
'_/ 【条件判定の実行】で結果を出せるように設計してあります。
'_/ この関数では、２００７年施行の改正祝日法(昭和の日)までを
'_/ サポートしています(９月の国民の休日を含む)。
'_/
'_/ (*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
' 時刻データ(小数部)は取り除いてあるので、下記の日付との比較はＯＫ
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
'第３月曜日(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.
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
７．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
８．当ブックを一旦どこかのフォルダに保存し、
同じフォルダに単色の画像ファイル"Dummy.bmp"を作成してください。
画像ファイルの名前や拡張子を変えるときは、コードの中もそれに合わせて変更してください。
９．UserForm1を実行してください。
（nagashima） 2014/02/25(火) 23:32
コードを実行してみました。
便利ですねえ。これがあれば、カレンダーコントロールのアクセスの所有物だから どうのこうの なんてこと気にせずにカレンダーが使えそうですね！！
便利なのでクラスは、別アドイン等で利用するような完全カプセル化で運用できると良いですね
>５５歳から６６歳の間は、ExcelVBA,VB5,Oracleを使ったアプリ開発を行いました。 >そして昨年退職したとういう経歴です。
私は、今年その55歳になります。 大先輩ですね！！
（ichinose） 2014/03/02(日) 21:13
こんにちは、nagashimaです。
クラスは、別アドイン等で利用するような完全カプセル化で運用できると良いですね
なるほどいいアイデアですね。
参照設定さえ問題なければできそうですね。
機会を見てトライしてみます。
（nagashima） 2014/03/03(月) 11:24
こんばんは、nagashimaです。
>クラスは、別アドイン等で利用するような完全カプセル化で運用できると良いですね カレンダークラスをアドインで利用するカプセル化が、 ほぼ出来たようなので報告します。 良ければ試してみてください。
（概要）
前回のサンプルのうち、２個のクラス部分をアドイン側とし、
ユーザフォーム部分をアドインを使用する側として、
二つのブックに分けます。
但し、アドインを使用する側からは、Newキーワードで、
直接クラスのインスタンスを作ることが出来ないので、
アドイン側に「クラスのインスタンスを作って、それを返す」関数を用意し、
アドインを使用する側から呼んでもらいます。
（手順）
１．「カレンダークラス.xlsx」を作成し、以下のようにします。
１−１）標準モジュールを１個作成し、下記のコードを貼り付けます。
Public Function Create_uCalndr() As uCalndr Set Create_uCalndr = New uCalndr End Function
１−２）クラスモジュール「uCalndr」と「uCalndr_Child」を作成し、
前回と同じコードを貼り付けます。
１−３）クラスモジュール「uCalndr」のプロパティで、InstancingをPublicNoCreatableに設定します。
１−４）ツール ⇒ 参照設定で、「Microsoft Forms2.0 Object Library」にチェックを入れ、参照します。
（※参照設定画面に表示されない場合は、一旦ユーザフォームを挿入してから削除します。）
１−５）ツール ⇒ VBAProject のプロパティ ⇒ 「全般」タブ ⇒ プロジェクト名を、「カレンダークラス」に変更します。
（※他のプロジェクトから参照設定されるときに、名前をユニークにするため。）
１−６）コードを見られたくないときは、
ツール ⇒ VBAProject のプロパティ ⇒ 「保護」タブ で、
「プロジェクトを表示用にロックする」にチェックを入れ、パスワードを設定します。
１−７）当ブックを一旦保存しておいてから、
名前を付けて保存 ⇒ その他の形式 ⇒ Excel アドイン(*.xlma)で、「カレンダークラス.xlam」を保存し、閉じます。
１−８）前回と同様に、「カレンダークラス.xlam」を保存したフォルダと同じフォルダに、
単色の画像ファイル"Dummy.bmp"を作成してください。
２．Excelを起動し直したのち、
Excel のオプション ⇒ アドイン ⇒ 「設定」ボタン ⇒ アドイン画面で、
「カレンダークラス」にチェックを入れ、アドインを登録し、
再度Excelを起動し直します。
３．「カレンダーテスト.xlsx」を作成し、以下のようにします。
３−１）ユーザーフォーム（UserForm1）を作成し、前回と同様に、
フレームを１個（Frame1）と、テキストボックスを３個（TextBox1〜TextBox3）配置します。
３−２）UserForm1のフォームモジュールに、前回と同じコードを貼り付けたのち、
Set uCAL01 = New uCalndr を
Set uCAL01 = カレンダークラス.Create_uCalndr に変更します。
３−３）ツール ⇒ 参照設定で、「カレンダーテスト」にチェックを入れ、参照します。
３−４）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.