Results of 1 - 1 of about 1239 for カレンダー (0.001 sec.)
- [[20100728102355]]
- #score: 6129
- @digest: 6541292da07a3c4801f8e0d2a0f78e77
- @id: 50648
- @mdate: 2014-03-09T01:20:01Z
- @size: 66161
- @type: text/plain
- #keywords: baseframe (183826), newval (146904), ucalndr (145997), wchild (137188), nagashima (125217), dateheight (123469), backcolor (108675), 日= (65096), 単色 (63145), forecolor (61711), holiday (60080), 分日 (57280), ラベ (40498), label (36587), property (33837), 色設 (32449), ベル (24642), 祝日 (24159), msforms (22679), カレ (18973), 像フ (17054), height (16199), 日" (14736), controls (12764), caption (12163), トロ (12024), レン (11810), width (11510), ンダ (10414), クラ (9994), ダー (9645), 生成 (9502)
- 『ユーザーフォームのラベル文字を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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201007/20100728102355.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97007 documents and 608075 words.
訪問者：