日付スタンプ

日付スタンプ

下記のコマンドを実行すると　日付をスタンプする。

Procedure DateStamp;
{
平成１２年　１月２４日-8.5J3 図形名称と属性のチェック追加
平成１１年　６月　６日-1.01
平成１１年　１月２０日-1.0
著作・製作　エーアンドエー株式会社
}
{*/// 
ｩ1999, Diehl Graphsoft, Inc.
This procedure updates or creates a text string named "Date Stamp"
Developed by Tom Urie
///*}
LABEL 99;

CONST
	kB1 = 'OK';
	kB2 = 'キャンセル';
	kTitle = '日付スタンプ';
	kTextStringName = '日付スタンプ';

	kD1GB1 = ' 表示内容 ';
	kD1GB1B1 = '日付のみ';
	kD1GB1B2 = '日付と時刻';
	kD1GB1B3 = '時刻のみ';

	kD1GB2 = ' 表示形式 ';
	kD1GB2B1 = '1998年, 8月 5日, 水曜日';
	kD1GB2B2 = '1998年, 8月5日, (水)';
	kD1GB2B3 = '98.8.5';

	kD1GB3 = ' オプション ';
	kD1GB3B1 = '更新機能を使う';
	kD1GB3B2 = '更新機能を使わない';

	kD2F9 = 'アップデートする日付スタンプがありません。';

	kD2GB1 = ' オプション ';
	kD2GB1B1a = 'マウスクリックで日付スタンプを配置し、';
	kD2GB1B1b = '「日付スタンプ」という名前をつけます';
	kD2GB1B2a = 'マウスクリックで日付スタンプを配置しますが、';
	kD2GB1B2b = '名前はつけません';
	kAlert1 = '図形名称「日付スタンプ」がテキスト以外の図形につけられているため、更新できません';

VAR
	x, y : REAL;
	dateFormat, infoFormat, optionA, optionB : INTEGER;
	textH : HANDLE;
	dateValue, textStringName : STRING;
	Abort : BOOLEAN;


Procedure Dialogs;
{*/// This procedure defines the dialog boxes ///*}
VAR
	Width, x1, y1, x2, y2, px1, px2, px3, px4, py1, py2, py3, py4 : INTEGER;

Procedure AlignScr (Height, Width : INTEGER; VAR x1, x2, y1 : INTEGER);
VAR
	scrx1, scry1, scrx2, scry2 : INTEGER;

BEGIN
	GetScreen (scrx1, scry1, scrx2, scry2);
	x1 := ((scrx1 + scrx2) DIV 2) - (Width DIV 2);
	x2 := x1 + Width;
	y1 := (scry2 - scry1 - Height) DIV 3;
END;	{of AlignScr}


Procedure LocateButtons (DialogType, scnh, scnw : INTEGER);
{*/// This procedure locates the 'OK' and 'Cancel' buttons ///*}
VAR
	v1, v2, v3, v4 : INTEGER;
	Mac : BOOLEAN;

Procedure Swap (VAR  m1, m2, m3, m4 : INTEGER);
VAR
	Temp : INTEGER;

BEGIN
	Temp := m1;
	m1 := m3;
	m3 := Temp;
	Temp := m2;
	m2 := m4;
	m4 := Temp;
END;		{of Swap}

BEGIN
	Mac := FALSE;
	GetVersion (v1, v2, v3, v4);
	IF v4 = 1 THEN Mac := TRUE;

	IF DialogType = 1 THEN
	BEGIN
		px1 := (scnw DIV 2) - 80;
		px2 := (scnw DIV 2) - 10;
		px3 := (scnw DIV 2) + 10;
		px4 := (scnw DIV 2) + 80;
		IF Mac THEN SWAP (px1, px2, px3, px4);

		py1 := scnh - 40;
		py2 := scnh - 20;
		py3 := py1;
		py4 := py2;
	END

	ELSE IF DialogType = 2 THEN
	BEGIN
		px1 := scnw - 180;
		px2 := scnw - 110;
		px3 := scnw - 90;
		px4 := scnw - 20;
		IF Mac THEN SWAP (px1, px2, px3, px4);

		py1 := scnh - 40;
		py2 := scnh - 20;
		py3 := py1;
		py4 := py2;
	END

	ELSE BEGIN
		px1 := scnw - 90;
		px2 := scnw - 20;
		px3 := px1;
		px4 := px2;

		py1 := scnh -70;
		py2 := scnh - 50;
		py3 := scnh - 40;
		py4 := scnh - 20;
		IF Mac THEN SWAP (py1, py2, py3, py4);
	END;
END;		{of Locate Buttons}


Procedure MakeDialog1;
CONST
	scnw = 430;
	scnh = 235;
	DialogType = 1;

VAR
	g, h : INTEGER;

BEGIN
	AlignScr (scnh, scnw, x1, x2, y1);
	y2 := y1 + scnh;

	LocateButtons (DialogType, scnh, scnw);

	BeginDialog (1, 1, x1, y1, x2, y2);
		AddButton (kB1, 1, 1, px1, py1, px2, py2);
		AddButton (kB2, 2, 1, px3, py3, px4, py4);

		g := 20;
		h := 10;
		AddGroupBox (kD1GB1, 9, g, h, 140+g, 85+h);
		AddButton (kD1GB1B1, 10, 5, 10+g, 20+h, 105+g, 35+h);
		AddButton (kD1GB1B2, 11, 5, 10+g, 40+h, 130+g, 55+h);
		AddButton (kD1GB1B3, 12, 5, 10+g, 60+h, 105+g, 75+h);

		g := 180;
		AddGroupBox (kD1GB2,5, g, h, 230+g, 85+h);
		AddButton (	kD1GB2B1, 6, 5, 10+g, 20+h, 210+g, 35+h);
		AddButton (	kD1GB2B2, 7, 5, 10+g,40+h, 175+g, 55+h);
		AddButton (	kD1GB2B3, 8, 5, 10+g, 60+h, 175+g, 75+h);

		g := 20;
		h := 105;
		AddGroupBox (kD1GB3,13, g, h, 390+g, 65+h);
		AddButton (	kD1GB3B1, 14, 5, 10+g, 20+h, 380+g, 35+h);
		AddButton (	kD1GB3B2, 15, 5, 10+g, 40+h, 380+g, 55+h);
	EndDialog;
END;


Procedure MakeDialog2;
CONST
	scnw = 370;
	scnh = 205;
	DialogType = 1;

VAR
	g, h : INTEGER;

BEGIN
	AlignScr (scnh, scnw, x1, x2, y1);
	y2 := y1 + scnh;

	LocateButtons (DialogType, scnh, scnw);
	
	BeginDialog (2, 1, x1, y1, x2, y2);
		AddButton (kB1, 1, 1, px1, py1, px2, py2);
		AddButton (kB2, 2, 1, px3, py3, px4, py4);

		g := 20;
		h := 10;
		AddField (kD2F9,9, 1, g, h-1, scnw-20, 20+h);

		g := 20;
		h := 40;
		AddGroupBox (kD2GB1,13, g, h, scnw-20, 105+h);
		AddButton (kD2GB1B1a, 14, 5, 10+g, 20+h, scnw-25, 35+h);
		AddField (kD2GB1B1b, 16, 1, 30+g, 37+h, scnw-25, 53+h);
		AddButton (kD2GB1B2a, 15, 5, 10+g, 60+h, scnw-25, 75+h);
		AddField (kD2GB1B2b, 17, 1, 30+g, 77+h, scnw-25, 93+h);
	EndDialog;
END;


BEGIN
	MakeDialog1;
	MakeDialog2;
END;


Procedure GetInfo1;
VAR
	Item : INTEGER;
	Done : BOOLEAN;

BEGIN
	Done := FALSE;
	Abort := FALSE;

	optionA := 1;
	infoFormat := 0;
	dateFormat := 0;

	GetDialog (1);
	SetTitle (kTitle);
	SetItem (dateFormat + 6, TRUE);
	SetItem (infoFormat + 10, TRUE);
	SetItem (optionA + 13, TRUE);

	REPEAT
		DialogEvent (item);

		CASE item OF
		1 :
			Done := TRUE;

		2 :
		BEGIN
			Done := TRUE;
			Abort := TRUE;
		END;

		6..8 :
			dateFormat := Item - 6;

		10..12 :
		BEGIN
			infoFormat := Item - 10;
			SetItemEnable (6, infoFormat <> 2);
			SetItemEnable (7, infoFormat <> 2);
			SetItemEnable (8, infoFormat <> 2);
		END;

		14, 15 :
			optionA := Item - 13;

		END;	{CASE}

	UNTIL Done;
	ClrDialog;
END;


Procedure GetInfo2;
VAR
	Item : INTEGER;
	Done : BOOLEAN;

BEGIN
	Done := FALSE;
	Abort := FALSE;

	optionB := 1;

	GetDialog (2);
	SetTitle (kTitle);

	SetItem (optionB + 13, TRUE);

	REPEAT
		DialogEvent (item);

		CASE item OF
		1 :
			Done := TRUE;

		2 :
		BEGIN
			Done := TRUE;
			Abort := TRUE;
		END;

		14, 15 :
			optionB := Item - 13;

		END;	{CASE}

	UNTIL Done;
	ClrDialog;
END;


BEGIN
	Dialogs;
	GetInfo1;
	IF Abort THEN GOTO 99;

	dateValue := Date (dateFormat, infoFormat);
	textStringName := kTextStringName;

	IF optionA = 1 THEN
	BEGIN
		textH := GetObject (textStringName);
		IF textH = NIL THEN
		BEGIN
			Sysbeep;
			GetInfo2;
			IF NOT Abort THEN
			BEGIN
				GetPt (x, y);
				TextOrigin (x, y);
				CreateText (dateValue);
				IF optionB = 1 THEN
					SetName (LNewObj, textStringName);
			END;
		END

		ELSE IF GetType (textH) <> 10 THEN
		BEGIN
			SysBeep;
			AlrtDialog (kAlert1);
			GOTO 99;
		END

		ELSE
			SetText (textH, dateValue);
	END

	ELSE BEGIN
		GetPt (x, y);
		TextOrigin (x, y);
		CreateText (dateValue);
	END;

99: END;

RUN (DateStamp);