MkCaldraw.csc

　現在の用紙にカレンダーを作成する。
　余白は用紙サイズの10%、タイトルは余白左上、曜日見出しは上から25%～30%の範囲に、各日付は曜日見出しの下に均等に割り当てる。
　基本的な機能だけなので、祝日や振替には対応していない。

---

'Make Basic Calendar(DRAW)
'by Albatross
'2000/11/4 Ver 1.00

declare sub PutStr(x as long, y as long,ps as string)

global DH as long,DW as long

dim xs as long, ys as long
dim mh as long, mw as long

dim oy as integer, om as integer
dim cd as date
dim iy as integer,im as integer,id as integer,iw as integer
dim c1 as integer, c2 as integer

dim fon as string
dim fos as double

dim ws(0 to 6) as string
ws(0)="Sun"
ws(1)="Mon"
ws(2)="Tue"
ws(3)="Wed"
ws(4)="Thur"
ws(5)="Fri"
ws(6)="Sat"

oy=val(inputbox("作成年を西暦で入力してください"))
om=val(inputbox("作成月を入力してください"))
cd=BUILDDATE(oy, om, 1) 
getdateinfo cd, iy, im, id, iw

cd=cd-iw+1

WITHOBJECT "CorelDraw.Automation.9"
    .SuppressPainting TRUE
    .getcurrentPagesize DW, DH
    mh=int(DH*0.1)
    mw=int(DW*0.1)

    putstr mw, DH-mh,cstr(om)+" ["+cstr(oy)+"]"
    .CreateRectangle DH/2-int(DH*0.25), -(DW/2)+mw, -(DH/2)+mh, DW/2-mw, 0, 0, 0, 0
    .CreateRectangle DH/2-int(DH*0.25), -(DW/2)+mw, (DH/2)-int(DH*0.3), DW/2-mw, 0, 0, 0, 0
    .StoreColor 5, 0, 0, 0
    .ApplyUniformFillColor 
    .UnSelectAll 

    xs=int((DW-(2*mw))/7)
    ys=int((int(DH*0.7)-mh)/6)

'MkGrid
    FOR c1 = 1 TO 5
        .BeginDrawCurve  -(DW/2)+mw,clng((DH/2)-int(DH*0.3)-(c1*ys))
            .DrawCurveLineTo (DW/2)-mw,clng((DH/2)-int(DH*0.3)-(c1*ys))
            .EndDrawCurve 
    NEXT c1

    FOR c1 = 1 TO 6
        .BeginDrawCurve -(DW/2)+mw+c1*xs,(DH/2)-int(DH*0.3)
            .DrawCurveLineTo -(DW/2)+mw+c1*xs,-(DH/2)+mh
            .EndDrawCurve 
    NEXT c1

'Put WeekStr
    FOR c1 = 0 TO 6
        getdateinfo cd, iy, im, id, iw
        putstr clng(c1*xs+mw),clng(DH-int(DH*0.25)-10000), ws(c1)
        .StoreColor 5, 255, 255, 255
        .ApplyUniformFillColor 
    NEXT c1

'Put Date
    FOR c1 = 0 TO 5
        FOR c2 = 0 TO 6
            getdateinfo cd, iy, im, id, iw
            putstr clng(c2*xs+mw),clng(DH-int(DH*0.3)-(c1*ys)), cstr(id)
            select case iw
                case 1
                    .StoreColor 5, 255, 0, 0
                case 7
                    .StoreColor 5, 0, 0, 255
                case else
                    .StoreColor 5, 0, 0, 0
            end select
            .ApplyUniformFillColor
            if om<>im then
                fon=.gettextfontname()
                fos=.gettextfontsize()
                .SetCharacterAttributes 0,0,fon,8,fos*7,0,0,0,0,0,0,0,0
            endif 
            cd=cd+1
        NEXT c2
    NEXT c1
.ResumePainting 
END WITHOBJECT
end

sub PutStr(x as long, y as long, ps as string)
dim fs as integer
dim l as long, t as long
WITHOBJECT "CorelDraw.Automation.9"
    l=x-(DW/2)
    t=y-(DH/2)
    .CreateArtisticText ps, l,t
    fs=.gettextfontsize()
    .MoveObject 0,-LENGTHCONVERT (3,7,fs)
END WITHOBJECT
end sub

---

＜＜戻る