【4】1年間の祝日を洗い出す
1年間の祝日には春分・秋分の日などや、第2・第3月曜に決められた成人の日など、振替休日など日付が変わるものがある。 といっても面倒なだけで、難しいところはない。 実際のコーディングは【蛇足】を参照。 【5】祝日のフォント・赤丸・祝日名などを、カレンダーに貼り付ける。 祝日・記念日のセルの位置は、GetTrgCellを使って取得している。 テキストShapeや丸印などは、PaternシートのDrawPageにあり、登録順の番号で取得できる。 このときの番号は、シート番号などと同様に0から始まる。(Excelでは1から) さらに、ExcelではShapeをシートに貼り付けたが、Calcではセルを指定して張り付ける。 シェイプは左図のように、セルの左上に貼り付けられてしまう。 これではみっともないので、位置の修正をする。 その微調整でも、Excelはたぶんピクセル単位だが、Calcでは1/100ミリ単位とかで違っている。 VBAからCalcに移植しようとして四苦八苦しているさまを目にするが、私はその逆。 戸惑うことも多いが、「こんなに簡単!」と思うことの方が多い。 以上の手順で、左図のようなカレンダーが作成される。 (5/9の星印は孫の誕生日) 【6】仕上げ 完成したカレンダーを、『カレンダー20xx.ods』という名前で保存する。 マクロが入った『カレンダー作成.ods』は閉じる。 【蛇足】Calcのコーディング 本文ではコーディングを省いたので、興味があれば是非に。 ↓ Excelでしたように、Calcのコーディングのほぼ全体を、最初にグローバル変数を定義しているのは、Sub・Functionで、たくさんのパラメータを使わなくてもすむようにと。 Option Explicit '=========== マクロ実行のため ================== Dim Disptch as Object '=========== Calc のドキュメント・シートなど ============= '---- ひな型およびマークが保存されているドキュメント ---- Public oldDoc as Object Public oldSheets as Object Public oldSheet as Object public oldController as Object '---- 新規に作成されるカレンダー ---- Public newDoc as Object Public newSheets as Object Public newSheet as Object public newController as Object '=========== 作成するカレンダーの年度 ============ Public YY as Integer '=========== 祝日 & 記念日 & 祝日数 ============= Public Holidays( 20 ) as Date Public Aniversarys( 8 ) as Date Public CountHoliday as Integer Sub Main '---- Dispatcherの取得 ------- Disptch = createUnoService( "com.sun.star.frame.DispatchHelper" ) '---- ひな型のドキュメントを取得 ---- oldDoc = ThisComponent oldSheets = oldDoc.GetSheets() oldController = oldDoc.GetCurrentController() '---- カレンダーのひな型を新規ドキュメントにコピー ---- oldSheet = oldSheets.GetByIndex( 1 ) oldController.SetActiveSheet(oldSheet) Dim array( 2 ) as new com.sun.star.beans.PropertyValue array( 0 ).Name = "DocName" array( 0 ).Value = "" array( 1 ).Name = "Copy" array( 1 ).Value = true Disptch.executeDispatch( oldController.Frame, ".uno:Move", "", 0, array() ) '---- 新規作成したドキュメントの対応付け ---- newDoc = starDesktop.CurrentComponent newSheets = newDoc.GetSheets() newController = newDoc.GetCurrentController() '---- 作成するカレンダーの年度を取得 ---- oldSheet = oldSheets.GetByIndex( 0 ) YY = oldSheet.GetCellByPosition( 2, 7 ).Value '---- 新規ドキュメントへのシートのコピー ---- CopyModel() '---- その年度の祝日・振替休日・記念日を取得する ---- GetHoliday() '---- 祝日および記念日をカレンダーに表示 ---- SetHoliday() SetAniversary() '---- 終了処理 ---- EndProc() End Sub '============ カレンダーのひな型をコピー ========== Sub CopyModel '---- コピーしたシートの名前を変更 ---- newSheet = newSheets.GetByIndex( 0 ) newSheet.Name = "1月" '---- さらに必要枚数だけコピー ---- newSheets.CopyByName( "1月", "3月", 32767) newSheets.CopyByName( "1月", "5月", 32767) … '--- 各月の月初めの日付のセット ---- Dim I as Integer For I = 0 to 5 newSheet = newSheets.GetByIndex( I ) newSheet.GetCellByPosition(3,1).Value = DateSerial(YY,I*2+1,1) newSheet.GetCellByPosition(11, 1).Value = DateSerial(YY,I*2+2,1) Next I End Sub '=========== 祝日および記念日の日付を取得する ======== Sub GetHoliday () Dim wrkDate as Date Dim wrkDay as integer '---------- 振替休日がないときの祝日数 -------- CountHoliday = 15 '---------- 元旦 ------- Holidays(0) = DateSerial(YY, 1, 1) If Weekday(Holidays(0))= 1then '---- 振替休日 --- Holidays(CountHoliday) = DateSerial(YY, 1, 2) CountHoliday = CountHoliday + 1 End If '---------- 成人の日 ------- wrkDate = DateSerial(YY, 1, 8) wrkDay = Weekday(wrkDate) If wrkDay = 2 then Holidays(1) = wrkDate ElseIf wrkDay = 1 then Holidays(1) = wrkDate + 1 Else Holidays(1) = wrkDate + 9 - wrkDay End If … '---------- 春分の日 ------- wrkDay = int(20.843 + 0.242194 * (YY - 1980) - int((yy - 1980) / 4) Holidays(3) = DateSerial(yy, 3, wrkDay) … '---------- 秋分の日 ------- wrkDay = int(23.2488 + 0.242194 *(YY - 1980) - int((yy - 1980)/ 4) Holidays(10) = DateSerial(yy,9,wrkDay) … '---------- 誕生日・家族の記念日 ------- Aniversarys( 0 ) = DateSerial( YY, ?, ? ) End Sub 振替休日のコーディングは繰り返しになるので、省略した。 成人・海・敬老・体育の日、および憲法記念日・みどりの日には、振替休日はない。 '============ 祝日をセットする =========== Sub SetHoliday Dim oldDrawPage as Object Dim oldDraw As Object Dim trgDrawPage as Object Dim trgDraw as Object Dim trgPos As New com.sun.star.awt.Point Dim trgCell as Object Dim Dummy() '---- 登録されているシェイプなどを取得 ---- oldSheet =oldSheets.GetByName( "patern" ) oldDrawPage = oldSheet.GetDrawPage() Dim I as Integer For I = 0 to CountHoliday - 1 '------ 対象の祝日のセルを取得 ---- trgCell = GetTrgCell( HoliDays( I ) ) '------ 祝日のフォントを赤に ---- trgCell.CharColor = RGB( 255, 0, 0 ) '------ 数字を丸で囲む ------- oldDraw = oldDrawPage.GetByIndex( 24 ) oldController.select( oldDraw ) Disptch.executeDispatch( oldController.Frame, ".uno:Copy", "", 0, Dummy() ) newController.Select( trgCell ) Disptch.executeDispatch( newController.Frame, ".uno:Paste", "", 0, Dummy() ) 異なるドキュメント間のShapeのコピ・ペなので、それぞれのドキュメントに関連付けられたoldController、newControllerを使っていることに注意。 '--------- 貼り付けたマークの位置を調整する ----- trgDrawPage = newSheet.getDrawPage trgDraw = trgDrawPage.GetByIndex( trgDrawPage.GetCount() - 1 ) trgpos = trgDraw.GetPosition() trgPos.X = trgPos.X + 300 trgPos.Y = trgPos.Y + 50 trgDraw.SetPosition( trgPos ) DrawPageは各シートごとにあるので、OldDrawPageとは別物、直前に貼り付けたものはGetCount() - 1 の番号で取得できる。 '-------- 祝日の説明書き ------ If I > 14 then oldDraw = oldDrawPage.GetByIndex( 15 )'--- 振替休日 --- Else oldDraw = oldDrawPage.GetByIndex( I ) End If oldController.select( oldDraw ) Disptch.executeDispatch( oldController.Frame, ".uno:Copy", "", 0, Dummy() ) newController.Select( trgCell ) Disptch.executeDispatch( newController.Frame, ".uno:Paste", "", 0, Dummy() ) Next I End Sub '=== 対象となるセルを取得 《注 newSheetも切り替わる》 ===== Function GetTrgCell (trgDate as Date) as Object Dim MM as Integer Dim trgPos as integer Dim trgDays as Integer Dim trgX as integer Dim trgY as integer '-------- 月から対象のシートおよび左右を取得 ------ MM = Month(trgDate) newSheet = newSheets.GetByIndex(Int((MM - 1) / 2)) trgPos = 8 * ( (MM - 1) Mod 2) '------- 日数から対象のセルを取得 ------ trgDays = trgDate - newSheet.GetCellByPosition(trgPos, 3).Value trgX = trgPos + trgDays Mod 7 trgY = 3 + Int(trgDays / 7) GetTrgCell = newSheet.GetCellByPosition(trgX, trgY) End Function '============ 終了時の処理 =========== Sub EndProc '---- 作成したドキュメントを名前をつけて保存 ---- Dim oldURL as String Dim oldPath as String Dim oldName as String Dim newURL as String Dim newPath as String Dim newName as String Dim Dumy() oldURL = oldDoc.URL oldPath = ConvertFromURL(oldURL ) oldName = oldDoc.Title newName = "カレンダー" + YY + ".ods" newPath = Left( oldPath, Len( oldPath ) - Len( oldName ) ) + newName newURL = convertToURL( newPath ) If FileExists( NewURL ) Then msgBox( newPath + "は既に登録されています" ) Else newDoc.StoreAsURL( newURL, Dumy() ) End If '---- ファイルのクローズ ---- oldDoc.Dispose() End Sub
by t_ichib
| 2013-01-15 19:55
| 今日もまた老年プログラマー
|
プロフィール
カテゴリ
以前の記事
その他のジャンル
記事ランキング
|
ファン申請 |
||