沌珍館企画 開発部 部品倉庫 1F Delphiフロア

function GetMyMouseStatus(P: TPoint; R: TRect): integer;
// 0内 1左 2右 3上 4左上 5右上 6下 7左下 8右下（ちゃんと理由がある）
//┌─┬─┬─┐
//│ 4│ 3│ 5│
//├─┼─┼─┤
//│ 1│ 0│ 2│
//├─┼─┼─┤
//│ 7│ 6│ 8│
//└─┴─┴─┘
const
    mg: integer = 8;  //  センスマージン
begin
    {内側なら 0} Result := 0;
    {左端なら+1} if (P.X < R.Left + mg)   then Result := Result + 1;
    {右端なら+2} if (R.Right - mg < P.X)  then Result := Result + 2;
    {上端なら+3} if (P.Y < R.Top + mg)    then Result := Result + 3;
    {下端なら+6} if (R.Bottom - mg < P.Y) then Result := Result + 6;
end;

function SetMyResizeCursor(MouseStatus: integer): TCursor;
begin
    case MouseStatus of	{West,East,North,South}
        1,2: Result := crSizeWE;	{⇔}
        3,6: Result := crSizeNS;	{｜}
        4,8: Result := crSizeNWSE;	{＼}
        5,7: Result := crSizeNESW;	{／}
    else
        Result := crDefault;
    end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
var
    P: TPoint;	//  マウスカーソルの位置
    MyMouseStatus: integer;	//  0..8
begin
    GetCursorPos(P);	//  スクリーン系座標
    MyMouseStatus := GetMyMouseStatus(P, BoundsRect);
    Cursor := SetMyResizeCursor(MyMouseStatus);
    //  マウスの左ボタンを押されていなければ終わり
    if not (ssLeft in Shift) then exit;
    //
    ReleaseCapture;
    if MyMouseStatus = 0 then begin
        //  フォームをドラッグする
        SendMessage(Handle, WM_SYSCOMMAND, SC_MOVE or HTCAPTION, MakeLong(X,Y));
    end else begin
        //  フォームをリサイズする
        SendMessage(Handle, WM_SYSCOMMAND, SC_SIZE or MyMouseStatus, MakeLong(X,Y));
    end;
end;

procedure TForm1.MyDlgPaint(Sender :TObject);
//  uses  GraphUtil	//  usesに追加必要
//  { Private 宣言 }
//  procedure MyDlgPaint(Sender :TObject);	//  Privateに追加必要
//  { OnFormCreate }
//  Randomize;	//  FormCreateに追加必要
var
    sc1: TColor;	//  StartColor
    ec1: TColor;	//  EndColor
    gd1: TGradientDirection;
begin
    with TForm(Sender) do begin
        sc1 := clWhite;		// $FFFFFF
        ec1 := Random(sc1);	// $000000..sc1
        if odd(ec1) then
            gd1 := gdHorizontal  {→}
        else
            gd1 := gdVertical;   {↓}
        GradientFillCanvas(Canvas,sc1,ec1,ClientRect,gd1);
    end;
end;

procedure TForm1.About1Click(Sender: TObject);
//  グラデーションでバージョン表示
var
    MyDlg1 : TForm;	//  ダイアログも実体はフォーム
    Msg1 : string;
begin
    Msg1 := Application.Title + sLineBreak + Application.ExeName;
    MyDlg1 := CreateMessageDialog(Msg1,mtInformation,[mbOK]);
    with MyDlg1 do try
        Caption := 'バージョン情報';
        BorderIcons := [];
        Timage (Components[0]).Picture.Icon := Application.Icon;
        TLabel (Components[1]).Transparent := true;
        TLabel (Components[1]).AutoSize := true;
        TButton(Components[2]).Caption := 'おぅいぇ';
        TButton(Components[2]).Cursor := crHandPoint;
        Position := poScreenCenter;
        OnPaint := MyDlgPaint;  //  イベントハンドラを追加
        ShowModal;
    finally
        Free;
    end;
end;

var
    Color1, Color2 : Tcolor;
    Red1, Green1, Blue1 : integer; // $00..$FF
    Red2, Green2, Blue2 : integer; // $00..$FF

    Red1   := GetRValue(ColorToRGB(Color1)); // Windows API
    Green1 := GetGValue(ColorToRGB(Color1)); // Windows API
    Blue1  := GetBValue(ColorToRGB(Color1)); // Windows API

    //  延々と割り算して引き算していたのは知らなかっただけ

    Color2 := RGB(Red2,Green2,Blue2); // Windows API

    //  次々に掛け算して足し算していたのも知らなかったから

    Form1.Color := Random(clWhite);	//  clWhite = $FFFFFF

    //	FormCreateでRandomizeしておく

    SendMessage(ProgressBar1.Handle,PBM_SETBARCOLOR,0,Color2); // バー表示の色 Windows API
    ProgressBar1.Brush.Color := Color1; // バー背景の色

    SaveFileName1 := 'HelloWorld.exe';
    SaveFileName2 := ChangeFileExt(SaveFileName1,'Link.html');
//  → SaveFileName2 = 'HelloWorldLink.html'

procedure TForm1.MinimizeOthers;
//  他のアプリを最小化（戻らない）
begin
    //	[Windows]キーを押す
    Keybd_event(VK_LWIN, 0, 0, 0);
    //	[M]キーを押す
    Keybd_event(Byte('M'), 0, 0, 0);
    //	[M]キーを離す
    Keybd_event(Byte('M'), 0, KEYEVENTF_KEYUP, 0);
    //	[Windows]キーを離す
    Keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0);
end;

procedure TForm1.ShowDeskTop;
//  デスクトップを表示（再呼び出しで戻る）
begin
    //	[Windows]キーを押す
    Keybd_event(VK_LWIN, 0, 0, 0);
    //	[D]キーを押す
    Keybd_event(Byte('D'), 0, 0, 0);
    //	[D]キーを離す
    Keybd_event(Byte('D'), 0, KEYEVENTF_KEYUP, 0);
    //	[Windows]キーを離す
    Keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0);
end;

function IsProportionalFont(AFontName: string): boolean;
var
  TM1: TTextMetric;
begin
  Result := false;
  with TCanvas.Create do try
    Handle := CreateCompatibleDC(0);
    Font.Name := AFontName;
    GetTextMetrics(Handle,TM1) ;
    if (TM1.tmPitchAndFamily and TMPF_FIXED_PITCH) = TMPF_FIXED_PITCH then
      Result := true;
    DeleteDC(Handle);
  finally
    free;
  end;
end;

    var
        si : SCROLLINFO;	//  スクロール情報構造体
        ScrollPosX : integer;	//  横スクロール桁位置

    //  保存
    GetScrollInfo(TreeView1.Handle, SB_HORZ, si);	//  状況取得
    WriteInteger('OPTION', 'ScrollPosX', si.nPos);	//  保存

    //  復元
    ScrollPosX := ReadInteger('OPTION','ScrollPosX',0);	//  読出し
    ZeroMemory(@si, SizeOf(SCROLLINFO));	//  初期化
        si.cbSize := SizeOf(SCROLLINFO);
        si.fMask := SIF_POS;
        si.nPos := ScrollPosX;
    SetScrollInfo(TreeView1.Handle, SB_HORZ, si, true);	//  反映

    if RightStr(Url1,1) = '/' then Url1 := LeftStr(Url1,Length(Url1)-1);
    FileName1 := ExtractFileName(StringReplace(Url1,'/','\',[rfReplaceAll]));

    if (Memo1.Lines.IndexOf(Str1) = -1) and (Memo2.Lines.IndexOf(Str1) = -1) then
        // 既出とも新作とも重複しなければ
        begin
            Memo2.Lines.Add(Str1); // 新作として追加する
        end;

procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X,Y: Integer);
var
    Yi : integer; // Y方向のインデクス
begin
    if not ( ssRight in Shift ) then exit; // 右ボタンが押されていなければ終わり
    //
    Yi := Y div ListBox1.ItemHeight +  ListBox1.TopIndex; // 押されたのは何行めか
    if Yi >= ListBox1.Items.Count then exit; // 既存行の外なら終わり
    //
    ListBox1.ItemIndex := Yi; // 行を決めて
    Form1.ListBox1Click(self); // 左クリックしたことにして(ここで行選択される)
    PopupMenu1.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y); // その座標にポップアップ表示
end;

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
    if not (key in ['0'..'9',Char(VK_BACK)]) then Key := #0;
end;

//  Edit1.SelStart := Length(Edit1.Text);
    //  ↓  結果は同じ
    Edit1.SelStart := MaxInt;

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
    if key = Char(VK_RETURN) then
        begin
            key := #0;  //  副作用防止
            Form1.Button1Click(self);  //  Enterでさせたいことを記述
        end;
end;

uses
    Inifiles;
var
    IsCloseQuery : boolean;
    IsSaveStatus : boolean;
const
    VersionConst : string = 'V1.0';

procedure TForm1.FormCreate(Sender: TObject);
var
    IniFileName : string;
begin
    IniFileName := ChangeFileExt(Application.ExeName,'.ini');
    with TIniFile.Create(IniFileName) do
    try
        // 位置
        Top   := ReadInteger('POSITION','Top' , (Screen.Height - Height) div 2);
        Left  := ReadInteger('POSITION','Left', (Screen.Width  - Width ) div 2);
        Height:= ReadInteger('POSITION','Height', Height);
        Width := ReadInteger('POSITION','Width', Width);
        // オプション
        Mode1 := ReadBool   ('OPTION','Mode1',False);
        Name1 := ReadString ('OPTION','Name1','');
        Data1 := ReadInteger('OPTION','Data1',0);
        IsCloseQuery := ReadBool('OPTION','CloseQuery',false);
        IsSaveStatus := ReadBool('OPTION','SaveStatus',false);
    finally
        free;
    end;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
var
    IniFileName: string;
begin
    if IsCloseQuery then
        begin
            if Application.MessageBox('終了してもよいですか？' ,
              PChar(Application.Title), MB_YesNo + MB_IconQuestion) = IdNo then
                begin
                    CanClose := False; // Noなら終了をキャンセルして終わり
                    exit;
                end;
        end;
    // Ini書き込み
    IniFileName := ChangeFileExt(Application.ExeName,'.ini');
    with TIniFile.Create(IniFileName) do
    try
        // 概要
        WriteString('PROGRAM','Name',ExtractFileName(Application.ExeName));
        WriteString('PROGRAM','Path',ExtractFilePath(Application.ExeName));
        WriteString('PROGRAM','Version',VersionConst);
        // 位置
        EraseSection('POSITION');
        EraseSection('OPTION');
        if IsSaveStatus then
            begin
                WriteInteger('POSITION','Top',Top);
                WriteInteger('POSITION','Left',Left);
                WriteInteger('POSITION','Height',Height);
                WriteInteger('POSITION','Width',Width);
                // オプション
                WriteBool   ('OPTION','Mode1',Mode1);
                WriteString ('OPTION','Name1',Name1);
                WriteInteger('OPTION','Data1',Data1);
                WriteBool('OPTION','CloseQuery',IsCloseQuery);
                WriteBool('OPTION','SaveStatus',IsSaveStatus);
            end;
    finally
        Free;
    end;
end;

uses
    ShlObj, ActiveX, ComObj, Registry;

procedure TForm1.DeskTop1Click(Sender: TObject);
const
    MyRegFile : string = 'Software\Microsoft\Windows\CurrentVersion\Explorer';
    MyMessage : string = 'デスクトップに登録しますか？';
    MyFolders : string = 'Desktop';
//  -------------------------------------------------------------------------
//  ↓ここから下は共通
var
    MyObject : IUnknown;
    MySLink  : IShellLink; // ShlObj
    MyPFile  : IPersistFile; // ActiveX
    Directory : String;
    WFileName : WideString;
begin
    if Application.MessageBox(PChar(MyMessage),'確認',
        MB_YesNo + MB_IconQuestion) = IdNo then exit; // Noなら何もしないで終わり
    // Yesなら
    MyObject := CreateComObject(CLSID_ShellLink); // ComObj
    MySLink  := MyObject as IShellLink;
    MyPFile  := MyObject as IPersistFile;
    MySLink.SetPath(PChar(Application.ExeName));
    //
    with TRegIniFile.Create(MyRegFile) do // Registry
    try
        Directory := ReadString('Shell Folders',MyFolders,'') + '\';
        WFileName := Directory + Application.Title + '.Lnk';
        MyPFile.Save(PWChar(WFileName),False);
        ShowMessage(WFileName + ' に登録しました。'); // OKを押して終わり
    finally
        Free;
    end;
end;

procedure TForm1.StartUp1Click(Sender: TObject);
const
    MyRegFile : string = 'Software\Microsoft\Windows\CurrentVersion\Explorer';
    MyMessage : string = 'スタートアップに登録しますか？';
    MyFolders : string = 'Startup';
//  -------------------------------------------------------------------------
　　{以下同文}

procedure TForm1.StartMenu1Click(Sender: TObject);
const
    MyRegFile : string = 'Software\Microsoft\Windows\CurrentVersion\Explorer';
    MyMessage : string = 'スタートメニューのプログラムに登録しますか？';
    MyFolders : string = 'Programs';
//  -------------------------------------------------------------------------
　　{以下同文}

uses
     ShellAPI;

procedure TForm1.Help2Click(Sender: TObject);
var
    HelpFileName: string;
begin
    HelpFileName := ChangeFileExt(Application.ExeName,'.hlp');
    ShellExecute(handle,'open',PChar(HelpFileName),nil,nil,SW_SHOWNORMAL); // Windows API
end;

const
    VersionConst : string = 'V1.0'; // バージョン定数

procedure TForm1.About1Click(Sender: TObject);
var
    Text1,Text2,Text3 : string;
begin
    Text1 := '『'+Application.Title+'』のバージョン情報'; // タイトルバー用
    Text2 := 'Windows版『' + Application.Title + '』' + VersionConst; // 1行め
    Text3 := 'application built by 沌珍館企画 (C)2006'; // 2行め
    ShellAbout(Handle,Pchar(Text1+'#'+Text2),Pchar(Text3),Application.Icon.Handle); // Windows API
end;

procedure TForm1.Site1Click(Sender: TObject);
const
    SiteURL : string = 'http://hp.vector.co.jp/authors/VA012191/';
begin
    ShellExecute(handle,'open',PChar(SiteURL),nil,nil,SW_SHOWNORMAL); // Windows API
end;

procedure TForm1.Mail1Click(Sender: TObject);
var
    MailString: string;
    i: integer;
begin
    MailString := '?subject=【メール送信サンプル】&body=';
    for i := 0 to Memo1.Lines.Count - 1 do
        begin
            MailString := MailString + Memo1.Lines[i]+'%0D%0A';
            if length(MailString) > 2048 then break;
        end;
    ShellExecute(Application.Handle,'open',PChar(MailString),nil,nil,SW_SHOWNORMAL); // Windows API
end;

function YearToEto(year: integer): String;
begin
    case (( year + 8) mod 12 ) of
         0: result := '子･ね';
         1: result := '丑･うし';
         2: result := '寅･とら';
         3: result := '卯･う';
         4: result := '辰･たつ';
         5: result := '巳･み';
         6: result := '午･うま';
         7: result := '未･ひつじ';
         8: result := '申･さる';
         9: result := '酉･とり';
        10: result := '戌･いぬ';
        11: result := '亥･い';
    end;
end;

function DateToSeiza(Date1:TDateTime): string;
begin
    case StrToInt(FormatDateTime('mmdd',Date1)) of
         101.. 119: result := '山羊(やぎ)';	// Capricorn
         120.. 218: result := '水瓶(みずがめ)';	// Aquarius
         219.. 320: result := '魚(うお)';  	// Pisces
         321.. 419: result := '牡羊(おひつじ)';	// Aries
         420.. 520: result := '牡牛(おうし)';	// Taurus
         521.. 621: result := '双子(ふたご)';	// Gemini
         622.. 722: result := '蟹(かに)';  	// Cancer
         723.. 821: result := '獅子(しし)';	// Leo
         822.. 922: result := '乙女(おとめ)';	// Virgo
         923..1023: result := '天秤(てんびん)';	// Libra
        1024..1122: result := '蠍(さそり)';	// Scorpio
        1123..1221: result := '射手(いて)';	// Sagittarius
        1222..1231: result := '山羊(やぎ)';	// Capricorn
    else
        result := FormatDateTime('mm/dd',Date1);
    end;
    result := result+'座';
end;

begin
    while MyGuitar.GentlyWeeps do begin
        I.DontKnow(WHY, Nobody.Told(You), HowToUnfold(YourLove));
        I.DontKnow(HOW, Someone.Controlled(You));
        They.BoughtAndSold(You);
        with EveryMistake do try
            We.Must(SURELY, beLearning);
        finally
            still MyGuitar.GentlyWeeps;
        end;
    end;
end;