掲示板システム
ホーム
アクセス解析
カテゴリ
ログアウト
[DCC エラー] E2161 Error: RLINK32: Unsupported 16bit resource in fileエラー (ID：41995)
名前
ホームページ(ブログ、Twitterなど)のURL (省略可)
本文
Atchoumさん ありがとうございます。 TNStringGridですが、どうもコンポーネントを独自で作っているようです。 ソースをみましても到底理解できないレベルです。 コンポーネントをＵＰしますので、何かお分かりになることがありましたら お教え頂ければ助かります unit pppComponents; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, Mask, ComCtrls; type { ---------------------------------------------------------- 拡張Editコンポーネント : TNEdit <継承> TEdit ---------------------------------------------------------- 【追加プロパティ】 Alignment: TAlignment : 表示位置 taLeftJustify = 左寄せ taRightJustify = 右寄せ taCenter = 中央 EnterFocusMove: Boolean : EnterKeyでフォーカス移動 ColorChange: Boolean : カラー変更フラグ ※True の時にカラー変更処理を行う NormalColor: TColor : 通常のカラー ※このプロパティを変更するとColorプロパティも 同じ色に変更されます。 EnterColor: TColor : フォーカス時のカラー ErrorColor: TColor : エラー時のカラー ErrorFlg: Boolean : エラー有無フラグ 【追加メソッド】 無し ---------------------------------------------------------- } TNEdit = class(TEdit) private { Private 宣言 } // プロパティ FAlignment : TAlignment; // 表示位置 FEnterFocusMove: Boolean; // EnterKeyでフォーカス移動 FColorChange : Boolean; // フォーカス時にカラーを変更 FNormalColor : TColor; // 通常のカラー FEnterColor : TColor; // フォーカス時のカラー FErrorColor : TColor; // エラー時のカラー FErrorFlg : Boolean; // エラーフラグ // プロパティ操作 procedure SetAlignment(AValue: TAlignment); procedure SetEnterFocusMove(AValue: Boolean); procedure SetColorChange(AValue: Boolean); procedure SetErrorFlg(AValue: Boolean); procedure SetNormalColor(AValue: TColor); procedure SetEnterColor(AValue: TColor); procedure SetErrorColor(AValue: TColor); protected { Protected 宣言 } // オーバーライド procedure CreateParams(var Params: TCreateParams); override; procedure DoEnter; override; procedure DoExit; override; procedure KeyPress(var Key:Char); override; public { Public 宣言 } constructor Create(AOwner: TComponent); override; // 実行時プロパティ property Color; published { Published 宣言 } // 設計時プロパティ property Alignment : TAlignment read FAlignment write SetAlignment default taLeftJustify; property NormalColor : TColor read FNormalColor write SetNormalColor; property EnterColor : TColor read FEnterColor write SetEnterColor; property ErrorColor : TColor read FErrorColor write SetErrorColor; property EnterFocusMove: Boolean read FEnterFocusMove write SetEnterFocusMove default False; property ColorChange : Boolean read FColorChange write SetColorChange default False; property ErrorFlg : Boolean read FErrorFlg write SetErrorFlg default False; end; { ---------------------------------------------------------- 拡張Editコンポーネント(数値用) : TNEditNum <継承> TNEdit ---------------------------------------------------------- 【追加プロパティ】 IntValue : Integer : Integer型の入力値 FloatValue : Double : Double型の入力値 IntegerLength: Integer : 整数部の桁数 DecimalLength: Integer : 少数部の桁数 DecimalLength > 0 の時、ドット入力可 InputMinus : Boolean : マイナス入力の許可 Comma : Boolean : ３桁毎のカンマ区切り 【追加メソッド】 無し 【追加仕様】 数字のみ入力可 ---------------------------------------------------------- } TNEditNum = class(TNEdit) private { Private 宣言 } // プロパティ FIntValue : Integer; // Integer型のText(変換できない場合は'0') FFloatValue : Double; // Double型のText(変換できない場合は'0') FIntegerLength: Integer; // 整数部の桁数 FDecimalLength: Integer; // 小数部の桁数 FInputMinus : Boolean; // マイナス入力の許可 FComma : Boolean; // ３桁毎のカンマ区切り // プロパティ操作 procedure SetIntValue(AValue: Integer); procedure SetFloatValue(AValue: Double); procedure SetIntegerLength(AValue: Integer); procedure SetDecimalLength(AValue: Integer); procedure SetInputMinus(AValue: Boolean); procedure SetComma(AValue: Boolean); function GetIntValue: Integer; function GetFloatValue: Double; // メソッド procedure AddChar(var Key: Char ); procedure AddDot(var Key: Char ); procedure AddMinus(var Key: Char ); procedure ChkText; function EditText: String; function UnEditText: String; protected { Protected 宣言 } // オーバーライド procedure KeyPress(var Key:Char); override; procedure DoEnter ; override; procedure DoExit ; override; public { Public 宣言 } constructor Create(AOwner: TComponent); override; // 実行時プロパティ property IntValue : Integer read GetIntValue write SetIntValue; property FloatValue: Double read GetFloatValue write SetFloatValue; published { Published 宣言 } // 設計時プロパティ property IntegerLength: Integer read FIntegerLength write SetIntegerLength; property DecimalLength: Integer read FDecimalLength write SetDecimalLength; property InputMinus : Boolean read FInputMinus write SetInputMinus; property Comma : Boolean read FComma write SetComma; end; { ---------------------------------------------------------- 拡張ComboBoxコンポーネント : TNComboBox <継承> TCustomComboBox ---------------------------------------------------------- 【追加プロパティ】 BoundaryLine : TBoundaryLine : 複数列時：境界線 Columns : TCBColumns : 各列の内容を保持する TargetCol : Byte : ComboBox に表示する列 Indent : Integer : インデント EnterFocusMove: Boolean : EnterKeyでフォーカス移動 ColorChange : Boolean : フォーカス時にカラーを変更 NormalColor : TColor : 通常のカラー EnterColor : TColor : フォーカス時のカラー ErrorColor : TColor : エラー時のカラー ErrorOn : Boolean : エラーカラーへ InputSupport : Boolean : 入力支援ON/OFF SelectedText : string : 選択された項目を取得 取得されるのは TargetCol で指定された列の項目 【追加メソッド】 function ColIndexOf(const col: Integer; const s: string): Integer; col で指定した列の文字列 s の最初の位置を取得する function GetColText(col: Integer): string; ComboBox で選択された項目から col で指定した列の テキストを取得する ---------------------------------------------------------- } // ComboBox で使用するクラスを仮宣言 TCBColumn = class; TCBColumns = class; TBoundaryLine = class; TNComboBox = class(TCustomComboBox) private FEditDrawing : Boolean; FItems : TStringList; // プロパティ FBoundaryLine : TBoundaryLine; // 複数列時：境界線 FColumns : TCBColumns; // 各列 FTargetCol : Byte; // 表示列 FIndent : Integer; // インデント FEnterFocusMove: Boolean; // EnterKeyでフォーカス移動 FColorChange : Boolean; // フォーカス時にカラーを変更 FNormalColor : TColor; // 通常のカラー FEnterColor : TColor; // フォーカス時のカラー FErrorColor : TColor; // エラー時のカラー FErrorOn : Boolean; // エラーカラーへ FInputSupport : Boolean; // 入力支援ON/OFF function GetColumnText(idx, col: Integer): string; // プロパティ操作 procedure SetEnterFocusMove(AValue: Boolean); procedure SetColorChange(AValue: Boolean); procedure SetErrorOn(AValue: Boolean); procedure SetNormalColor(AValue: TColor); procedure SetEnterColor(AValue: TColor); procedure SetErrorColor(AValue: TColor); procedure SetInputSupport(AValue: Boolean); procedure SetBoundaryLine(AValue: TBoundaryLine); procedure SetColumns(columns: TCBColumns); function GetSelectedText: string; // メッセージ procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED; procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM; procedure CBGetLBText(var Message: TMessage); message CB_GETLBTEXT; procedure CBAddString(var Message: TMessage); message CB_ADDSTRING; procedure CBInsertString(var Message: TMessage); message CB_INSERTSTRING; procedure CBDeleteString(var Message: TMessage); message CB_DELETESTRING; procedure CBResetContent(var Message: TMessage); message CB_RESETCONTENT; procedure CBGetItemHeight(var Message: TMessage); message CB_GETITEMHEIGHT; protected // オーバーライド procedure DoEnter; override; procedure DoExit; override; procedure KeyPress(var Key:Char); override; procedure KeyUp(var Key: Word; Shift: TShiftState); override; procedure CreateParams(var Params: TCreateParams); override; procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; procedure DropDown; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetColText(col: Integer): string; function ColIndexOf(const col: Integer; const s: string): Integer; property Color; property SelectedText : string read GetSelectedText; published // 設計時プロパティ property NormalColor : TColor read FNormalColor write SetNormalColor; property EnterColor : TColor read FEnterColor write SetEnterColor; property ErrorColor : TColor read FErrorColor write SetErrorColor; property EnterFocusMove: Boolean read FEnterFocusMove write SetEnterFocusMove default False; property ColorChange : Boolean read FColorChange write SetColorChange default False; property ErrorOn : Boolean read FErrorOn write SetErrorOn default False; property InputSupport : Boolean read FInputSupport write SetInputSupport default False; property BoundaryLine : TBoundaryLine read FBoundaryLine write SetBoundaryLine; property TargetCol : Byte read FTargetCol write FTargetCol default 0; property Columns : TCBColumns read FColumns write SetColumns; property Indent : Integer read FIndent write FIndent default 2; property Ctl3D; property DragMode; property DragCursor; property DropDownCount; property Enabled; property Font; property ItemHeight; property Items; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property Style; property TabOrder; property TabStop; property Text; property Visible; property OnChange; property OnClick; property OnContextPopup; property OnDblClick; property OnDragDrop; property OnDragOver; property OnDrawItem; property OnDropDown; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMeasureItem; property OnStartDock; property OnStartDrag; end; { TBoundaryLine の宣言部 } TBoundaryLine = class(TPersistent) private // プロパティ FDrawing: Boolean; FColor : TColor; // プロパティ操作 procedure SetColor(col: TColor); procedure SetDrawing(AValue: Boolean); protected constructor Create; public procedure Assign(Source: TPersistent); override; published // 設計時プロパティ property Drawing: Boolean read FDrawing write SetDrawing Default True; property Color: TColor read FColor write SetColor Default clBlack; end; { TCBColumn の宣言部 } TCBColumn = class(TCollectionItem) private // プロパティ FWidth : Integer; FColor : TColor; FAlignment : TAlignment; FFont : TFont; FParentColor: Boolean; FParentFont : Boolean; procedure ParentColorChanged; procedure ParentFontChanged; procedure FontChanged(Sender: TObject); // プロパティ操作 function IsStoredColor: Boolean; function IsStoredFont: Boolean; procedure SetColor(AValue: TColor); procedure SetFont(AValue: TFont); procedure SetParentColor(AValue: Boolean); procedure SetParentFont(AValue: Boolean); protected procedure DrawColumn(Sender: TNComboBox; aRect: TRect; text: string; isSelected: Boolean); public constructor Create(Collection: TCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; published // 設計時プロパティ property Width: Integer read FWidth write FWidth; property Color: TColor read FColor write SetColor stored IsStoredColor; property Alignment: TAlignment read FAlignment write FAlignment default taLeftJustify; property Font: TFont read FFont write SetFont stored IsStoredFont; property ParentColor: Boolean read FParentColor write SetParentColor; property ParentFont: Boolean read FParentFont write SetParentFont; end; { TCBColumns の宣言部 } TCBColumns = class(TCollection) private FOwner: TNComboBox; procedure ColorChanged; procedure FontChanged; function GetItem(idx: Integer): TCBColumn; // プロパティ操作 procedure SetItem(idx: Integer; item: TCBColumn); protected function GetOwner: TPersistent; override; public constructor Create(AOwner: TNComboBox); property Items[idx: Integer]: TCBColumn read GetItem write SetItem; default; end; { ---------------------------------------------------------- 拡張StringGridコンポーネント : TNStringGrid <継承> TStringGrid ---------------------------------------------------------- 【追加プロパティ】 SortOptions : TSortOptions Spacing : Integer GridColumns : TGridColumns RowParams : TRowParams GridStriped : Boolean StripeColor : TColor StripeFont : TFont CellPadding : Integer Layout : TTextLayout FixedAlignment: TAlignment FocusDraw : Boolean FocusCellParam: Boolean FocusCellColor: TColor FocusCellFont : TFont 【追加メソッド】 ---------------------------------------------------------- } TSortOptions = (soBoth, soUpOnly, soDownOnly, soNon); TSortState = (bsUp, bsDown, bbNon); TSortUpKind = (bkUp, bkUpCustom); TSortDownKind = (bkDown, bkDownCustom); // 種類 TInputDataType = (dtString, dtInteger); TValidChars = set of char; TNInplaceEdit = class; TGridColumn = class; TGridColumns = class; TRowParam = class; TRowParams = class; TNStringGrid = class(TStringGrid) private FSetCol : Longint; FGetFixS : String; FSortFlg : Boolean; FSortOptions : TSortOptions; FSortUp : Boolean; // FSortUpGlyps : TBitmap; // FSortDownGlyps: TBitmap; // FGlyph : Pointer; FSpacing : Integer; FMouseDown : Boolean; FCursorSplit : Boolean; FGridColumns : TGridColumns; FRowParams : TRowParams; FGridStriped : Boolean; FStripeColor : TColor; FStripeFont : TFont; FCellPadding : Integer; FLayout : TTextLayout; FFixedAlignment: TAlignment; FFocusDraw : boolean; // セルフォーカス表示有無 FFocusCellParam: boolean; // セルフォーカス表示有無 FFocusCellColor: TColor; FFocusCellFont : TFont; FSaveBrush : TBrush; // 標準のキャンバス情報の保持 FSavePen : TPen; FSaveFont : TFont; FNowSortedCol : Integer; // 現在のソートキーセル procedure BubbleSortGrid(MotoGrid : TStringGrid; StartIdx, EndIdx, SortIdx : Integer); procedure QsortGrid(MotoGrid : TStringGrid; StartIdx, EndIdx, SortIdx : Integer); procedure QuickSortGrid(MotoGrid : TStringGrid; StartIdx, EndIdx, SortIdx : Integer); procedure SetSpacing(Value: Integer); procedure SetPropertyLayout(AValue: TTextLayout); procedure SetGridStriped(AValue: Boolean); procedure SetGridColumns(AValue: TGridColumns); procedure SetStripeColor(AValue: TColor); procedure SetStripeFont(AValue: TFont); procedure SetCellPadding(AValue: Integer); procedure SetFixedAlignment(AValue: TAlignment); procedure SetFocusDraw(AValue: Boolean); procedure SetFocusCellParam(AValue: Boolean); procedure SetFocusCellColor(AValue: TColor); procedure SetFocusCellFont(AValue: TFont); function GetBrushColor(ACol, ARow: integer): TColor; function GetDisplayText(AText, ADisplayMask: string): string; procedure DrawFixedFrame(ARect: TRect); procedure DrawFixedFramePushed(ARect: TRect); protected procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUP(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override; procedure KeyDown(var Key: Word; Shift:TShiftState); override; procedure KeyPress(var Key:Char); override; procedure SetEditText(ACol, ARow: Longint; const AValue: string); override; procedure SizeChanged(OldColCount, OldRowCount: Longint); override; function CanEditAcceptKey(Key: Char): Boolean; override; function CanEditModify: Boolean; override; function CreateEditor: TInplaceEdit; override; function GetEditText(ACol, ARow: Longint): string; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure UpdateScrollBar(Target: TScrollStyle); procedure GridToCsv(AFileName: String); overload; procedure GridToCsv; overload; procedure SelectionCellsToCsv(AFileName: String); overload; procedure SelectionCellsToCsv; overload; procedure SetColWidth(ACol: Integer); procedure SetAllColWidth; published property SortOptions: TSortOptions read FSortOptions write FSortOptions; property Spacing: Integer read FSpacing write SetSpacing default 10; property GridColumns: TGridColumns read FGridColumns write SetGridColumns; property RowParams: TRowParams read FRowParams write FRowParams; property GridStriped: Boolean read FGridStriped write SetGridStriped default False; property StripeColor: TColor read FStripeColor write SetStripeColor; property StripeFont : TFont read FStripeFont write SetStripeFont; property CellPadding : Integer read FCellPadding write SetCellPadding default 2; property Layout: TTextLayout read FLayout write SetPropertyLayout default tlTop; property FixedAlignment: TAlignment read FFixedAlignment write SetFixedAlignment default taLeftJustify; property FocusDraw: Boolean read FFocusDraw write SetFocusDraw default True; property FocusCellParam: Boolean read FFocusCellParam write SetFocusCellParam default False; property FocusCellColor: TColor read FFocusCellColor write SetFocusCellColor; property FocusCellFont : TFont read FFocusCellFont write SetFocusCellFont; end; { TNInplaceEdit の宣言部 } TNInplaceEdit = class(TInplaceEdit) private FMultiLine: boolean; FWordwrap: boolean; FImeMode : TImeMode; procedure SetWordWrap(AValue: boolean); protected procedure CreateParams(var Params: TCreateParams); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyPress(var Key:Char); override; published property ImeMode: TImeMode read FImeMode write FImeMode default imHira; property MultiLine: boolean read FMultiLine write FMultiLine; property WordWrap: boolean read FWordWrap write SetWordWrap; end; { TGridColumn の宣言部 } TGridColumn = class(TCollectionItem) private FAlignment : TAlignment; FCanEdit : boolean; FColor : TColor; FColumnName : string; FDataType : TInputDataType; FDisplayMask: string; FFixCellFont: TFont; FFont : TFont; FImeMode : TImeMode; FMultiLine : boolean; FWordwrap : boolean; procedure SetColor(AValue: TColor); procedure SetFixCellFont(AValue: TFont); procedure SetFont(AValue: TFont); procedure SetWordwrap(AValue: boolean); public constructor Create(Collection: TCollection); override; destructor Destroy; override; procedure Assign(AValue: TPersistent); override; procedure SetAlignment(AValue: TAlignment); procedure SetColumnName(AValue: string); published property Alignment: TAlignment read FAlignment write SetAlignment; property CanEdit: boolean read FCanEdit write FCanEdit; property Caption: string read FColumnName write SetColumnName; property Color: TColor read FColor write SetColor; property DataType: TInputDataType read FDataType write FDataType; property DisplayMask: string read FDisplayMask write FDisplayMask; property Font: TFont read FFont write SetFont; property FixCellFont: TFont read FFixCellFont write SetFixCellFont; property ImeMode: TImeMode read FImeMode write FImeMode default imHira; property Wordwrap: boolean read FWordwrap write SetWordwrap default false; property MultiLine: boolean read FMultiLine write FMultiLine default false; end; { TGridColums の宣言部 } TGridColumns = class(TCollection) private FCanSizing: boolean; FOwner: TNStringGrid; procedure SetItems(Index: Integer; AValue: TGridColumn); function GetItems(Index: Integer): TGridColumn; protected procedure Update(Item: TCollectionItem); override; function GetOwner: TPersistent; override; public constructor Create(AOwner: TNStringGrid); function Add: TGridColumn; property Items[Index: Integer]: TGridColumn read GetItems write SetItems; default; end; { TRowParam の宣言部 } TRowParam = class(TCollectionItem) private FColor : TColor; FName : String; FFont : TFont; FRow : Integer; FRowMax : Integer; FEnabled: Boolean; FTag : Integer; procedure SetColor(AValue: TColor); procedure SetFont(AValue: TFont); procedure SetPropertyRow(ARow: integer); procedure SetPropertyRowMax(ARowMax: integer); procedure SetEnabled(AValue: Boolean); public constructor Create(ACollection: TCollection); override; destructor Destroy; override; procedure Assign(AValue: TPersistent); override; published property Color: TColor read FColor write SetColor; property Font: TFont read FFont write SetFont; property Name: String read FName write FName; property Row: integer read FRow write SetPropertyRow; property RowMax: integer read FRowMax write SetPropertyRowMax; property Enabled: Boolean read FEnabled write SetEnabled default False; property Tag: integer read FTag write FTag; end; { TRowParams の宣言部 } TRowParams = class(TCollection) private FOwner: TNStringGrid; procedure SetItems(AIndex: Integer; AValue: TRowParam); function GetItems(AIndex: Integer): TRowParam; protected function GetOwner: TPersistent; override; procedure Update(AItem: TCollectionItem); override; public constructor Create(AOwner: TNStringGrid); function Add: TRowParam; function ItemByName(AName: string): TRowParam; property Items[Index: Integer]: TRowParam read GetItems write SetItems; default; end; { ---------------------------------------------------------- 拡張RichEditコンポーネント : TNRichEdit <継承> TEdit ---------------------------------------------------------- 【追加プロパティ】 Emphansis : Boolean : 構文強調する/しない PtnFileName: Stirng : 構文強調文字列定義ファイル名 【追加メソッド】 無し ---------------------------------------------------------- } TNRichEdit = class(TRichEdit) private { Private 宣言 } // プロパティ FEmphansis : Boolean; // 構文強調する FPtnFileName : String; // 構文強調定義ファイル名 FEmphansisForeColor: TColor; FEmphansisStyle : TFontStyles; procedure EmphansisSyntax; protected { Protected 宣言 } procedure Change; override; public { Public 宣言 } constructor Create(AOwner: TComponent); override; destructor Destroy; override; published { Published 宣言 } // 設計時プロパティ property Emphansis: Boolean read FEmphansis write FEmphansis; property PtnFileName: String read FPtnFileName write FPtnFileName; property EmphansisForeColor: TColor read FEmphansisForeColor write FEmphansisForeColor; property EmphansisStyle: TFontStyles read FEmphansisStyle write FEmphansisStyle; end; TSelectPos = Record spStart : Integer; spLength: Integer; end; procedure Register; implementation // TNStringGrid で DataType = dtInteger の時に入力可能な文字一覧 const VALID_CHARS: TValidChars = [#0..#32, '-', '+', '.', '0'..'9']; //var // SortResNamesUp : array[TSortUpKind] of PChar = ('BBUP', nil); // SortResNamesDown: array[TSortDownKind] of PChar = ('BBDOWN', nil); procedure Register; begin RegisterComponents('NBS', [TNEdit, TNEditNum, TNRichEdit, TNComboBox, TNStringGrid]); end; { ------------------------------------------------------- } { TNEdit の実装部 } { ------------------------------------------------------- } constructor TNEdit.Create(AOwner: TComponent); begin inherited Create(AOwner); FNormalColor := Color; FEnterColor := Color; FErrorColor := clRed; end; procedure TNEdit.DoEnter; begin if (not FErrorFlg) and (FColorChange) then Color := FEnterColor; inherited DoEnter; end; procedure TNEdit.DoExit; begin FErrorFlg := False; if (FColorChange) then Color := FNormalColor; inherited DoExit; end; procedure TNEdit.KeyPress(var Key:Char); var ParentForm: TCustomForm; begin Case Key of #13: // Enter begin if FEnterFocusMove then begin ParentForm := GetParentForm( Self ); // TFormが見つからない if ParentForm = nil then Exit; // 次コントロールへ移動 PostMessage( ParentForm.Handle, WM_NEXTDLGCTL, 0, 0 ); // キー無効 key := #0; end else begin // beep; // ビープ音を鳴らす。 end; // key := #0; // キー無効 end; end; inherited KeyPress(Key); end; procedure TNEdit.CreateParams(var Params: TCreateParams); const Alignments: array [TAlignment] of Longword = (ES_LEFT, ES_RIGHT, ES_CENTER); begin inherited CreateParams(Params); with Params do begin Style := Style or Alignments[FAlignment]; end; end; procedure TNEdit.SetNormalColor(AValue: TColor); begin if FNormalColor <> AValue then begin FNormalColor := AValue; Color := FNormalColor; Invalidate; end; end; procedure TNEdit.SetEnterColor(AValue: TColor); begin if FEnterColor <> AValue then begin FEnterColor := AValue; Invalidate; end; end; procedure TNEdit.SetErrorColor(AValue: TColor); begin if FErrorColor <> AValue then begin FErrorColor := AValue; Invalidate; end; end; procedure TNEdit.SetAlignment(AValue: TAlignment); begin if FAlignment <> AValue then begin FAlignment := AValue; RecreateWnd; end; end; procedure TNEdit.SetEnterFocusMove(AValue: Boolean); begin if FEnterFocusMove <> AValue then begin FEnterFocusMove := AValue; end; end; procedure TNEdit.SetColorChange(AValue: Boolean); begin if FColorChange <> AValue then begin FColorChange := AValue; end; end; procedure TNEdit.SetErrorFlg(AValue: Boolean); begin if FErrorFlg <> AValue then begin FErrorFlg := AValue; if FErrorFlg then begin Color := FErrorColor; end else begin Color := FNormalColor; end; end; end; { ------------------------------------------------------- } { TNEditNum の実装部 } { ------------------------------------------------------- } constructor TNEditNum.Create(AOwner: TComponent); begin inherited Create(AOwner); FIntegerLength := 9; FDecimalLength := 0; FInputMinus := False; FComma := False; Alignment := taRightJustify; Text := '0'; end; procedure TNEditNum.DoEnter; begin // テキスト非編集 Text := UnEditText; // 全選択? if AutoSelect then SelectAll; inherited DoEnter; end; procedure TNEditNum.DoExit; begin // テキストチェック ChkText; // テキスト編集 Text := EditText; inherited DoExit; end; procedure TNEditNum.KeyPress(var Key:Char); const ValidChar = [Char(VK_DELETE), Char(VK_BACK), Char(VK_RETURN), Char(VK_ESCAPE)]; begin // 数値のみ入力可能 if GetKeyState(VK_CONTROL) < 0 then Exit; // '.' 入力時 case Key of '.': begin AddDot( Key ); end; '-': begin AddMinus( Key ); end; '0'..'9': begin AddChar( Key ); end; else begin // キーが有効な文字群に含まれていなかった場合 if not (Key in ValidChar) then begin key := #0; // キー無効 beep; // ビープ音を鳴らす。 end; end; end; // case inherited KeyPress(Key); end; procedure TNEditNum.SetIntValue(AValue: Integer); begin if IntValue <> AValue then begin FIntValue := AValue; Text := IntToStr(FIntValue); // テキストチェック ChkText; // テキスト編集 Text := EditText; end; end; procedure TNEditNum.SetFloatValue(AValue: Double); begin if FloatValue <> AValue then begin FFloatValue := AValue; Text := FloatToStr(FFloatValue); // テキストチェック ChkText; // テキスト編集 Text := EditText; end; end; procedure TNEditNum.SetDecimalLength(AValue: Integer); begin if FDecimalLength <> AValue then begin FDecimalLength := AValue; end; end; procedure TNEditNum.SetIntegerLength(AValue: Integer); begin if FIntegerLength <> AValue then begin FIntegerLength := AValue; end; end; procedure TNEditNum.SetInputMinus(AValue: Boolean); begin if FInputMinus <> AValue then begin FInputMinus := AValue; end; end; procedure TNEditNum.SetComma(AValue: Boolean); begin if FComma <> AValue then begin FComma := AValue; end; end; function TNEditNum.GetIntValue: Integer; var iDotPos : Integer; sTempText: String; begin sTempText := UnEditText; iDotPos := AnsiPos('.', sTempText); if (iDotPos <> 0) then Delete(sTempText, iDotPos, Length(sTempText) - (iDotPos - 1)); FIntValue := StrToIntDef(sTempText, 0); Result := FIntValue; end; function TNEditNum.GetFloatValue: Double; begin try FFloatValue := StrToFloat(UnEditText); except FFloatValue := 0; end; Result := FFloatValue; end; // 数字 ------------------------------------------------------------------------ procedure TNEditNum.AddChar(var Key: Char); var iDotPos, iLen: Integer; begin // テキストが選択されている if SelLength > 0 then begin exit; end; // チェック iDotPos := AnsiPos('.', Text); if (iDotPos <= SelStart) and (iDotPos <> 0) then begin // 小数部桁数チェック if (FDecimalLength <= (Length(Text) - iDotPos)) then begin Beep; Key := #0; Exit; // 小数入力不可 end; end else begin // 整数部桁数チェック // 整数部桁数算出 if iDotPos <> 0 then iLen := iDotPos - 1 else iLen := Length(Text); if AnsiPos('-', Text) <> 0 then Dec(iLen); if FIntegerLength <= iLen then begin Beep; Key := #0; Exit; // 小数入力不可 end; end; end; // '.' ------------------------------------------------------------------------- procedure TNEditNum.AddDot(var Key: Char); begin // 小数部桁数＝０ if FDecimalLength = 0 then begin Beep; Key := #0; Exit; // 小数入力不可 end; // 全選択時 --> ブランクセット if SelLength = Length(Text) then begin Text := '0'; // キャレット移動 SelStart := Length(Text); Exit; end; // 既に'.'が入力されている if AnsiPos('.', Text) <> 0 then begin Beep; Key := #0; Exit; // 小数入力済み end; // 何も入力されていない if (Length(Text) = 0) or (SelLength = Length(Text)) then begin Text := '0'; // キャレット移動 SelStart := Length(Text); end; end; // マイナス -------------------------------------------------------------------- procedure TNEditNum.AddMinus(var Key: Char); var sTempText: String; iCaretPos: Integer; begin // マイナス許可？ if Not FInputMinus then begin Beep; Key := #0; Exit; end; // テキストが選択されている if SelLength > 0 then begin exit; end; // キャレット位置保存 iCaretPos := SelStart; // 既に'-'が入力されている if AnsiPos('-', Text) <> 0 then begin sTempText := Text; Delete(sTempText, 1, 1); Text := sTempText; Key := #0; Dec(iCaretPos); end else // '-'未入力 begin Text := '-' + Text; Key := #0; Inc(iCaretPos); end; // キャレット移動 SelStart := iCaretPos; end; // テキストチェック ------------------------------------------------------------ procedure TNEditNum.ChkText; var i, iLen, iLen2: Integer; sTemp,sTemp2 : String; chrTemp : Char; blDot : Boolean; begin iLen := Length(Text); // ブランクチェック if iLen = 0 then begin Text := '0'; exit; end; // 入力チェック sTemp := ''; sTemp2 := Text; blDot := False; for i := 1 to iLen do begin chrTemp := sTemp2[i]; case chrTemp of '0'..'9': begin iLen2 := Length(sTemp); if AnsiPos('-', sTemp) <> 0 then Dec(iLen2); if blDot then begin iLen2 := iLen2 - AnsiPos('.', sTemp); if FDecimalLength > iLen2 then sTemp := sTemp + chrTemp; end else if FIntegerLength > iLen2 then sTemp := sTemp + chrTemp; end; '-': if (i = 1) and (FInputMinus) then sTemp := sTemp + chrTemp; '.': if not blDot then begin sTemp := sTemp + chrTemp; blDot := True; end; end; // case end; // for Text := sTemp; // '.' チェック if (AnsiPos('.', Text) = iLen) then begin sTemp := Text; Delete(sTemp, iLen, 1); Text := sTemp; end; // '-' チェック if (AnsiPos('-', Text) <> 0) then case iLen of 1: Text := '0'; 2: if Text = '-0' then Text := '0'; end; end; // テキスト編集 ---------------------------------------------------------------- function TNEditNum.EditText: String; var iDotPos : Integer; sIntegerText: String; sDecimalText: String; begin // 初期処理 Result := Text; // カンマ編集有り if FComma then begin iDotPos := AnsiPos('.', Text); if (iDotPos <> 0) then begin sIntegerText := Copy(Text, 1, iDotPos - 1); sDecimalText := Copy(Text, iDotPos, Length(Text) - (iDotPos - 1)); end else begin sIntegerText := Text; sDecimalText := ''; end; Result := FormatFloat('#,##0', StrToFloat(sIntegerText)) + sDecimalText; end; end; // テキスト編集解除 ------------------------------------------------------------ function TNEditNum.UnEditText: String; var sTemp: String; begin // 初期処理 Result := Text; sTemp := Text; // カンマ編集有り if FComma then begin Result := StringReplace(sTemp, ',', '', [rfReplaceAll]); end; end; { ------------------------------------------------------- } { TNComboBox の実装部 } { ------------------------------------------------------- } procedure TNComboBox.CBAddString(var Message: TMessage); var strs: TStringList; str : string; begin strs := TStringList.Create; str := ''; try try strs.CommaText := PChar(Message.lParam); if FTargetCol < strs.Count then str := strs[FTargetCol]; finally strs.Free; end; finally FItems.Add(PChar(Message.lParam)); Message.lParam := LongInt(PChar(str)); inherited; end; end; procedure TNComboBox.CBDeleteString(var Message: TMessage); begin FItems.Delete(Message.wParam); inherited; end; procedure TNComboBox.CBGetItemHeight(var Message: TMessage); var item: TMeasureItemStruct; begin inherited; Perform(CN_MEASUREITEM, 0, LongInt(@item)); Message.Result := item.itemHeight; end; procedure TNComboBox.CBGetLBText(var Message: TMessage); begin inherited; if Message.Result <> CB_ERR then begin Message.Result := Length(FItems[Message.wParam]); StrPLCopy(PChar(Message.lParam), FItems[Message.wParam], 4096); end; end; procedure TNComboBox.CBInsertString(var Message: TMessage); var strs: TStringList; str : string; begin strs := TStringList.Create; str := ''; try try strs.CommaText := PChar(Message.lParam); if FTargetCol < strs.Count then str := strs.Strings[FTargetCol]; finally strs.Free; end; finally FItems.Insert(Message.wParam, PChar(Message.lParam)); Message.lParam := LongInt(PChar(str)); inherited; end; end; procedure TNComboBox.CBResetContent(var Message: TMessage); begin FItems.Clear; inherited; end; procedure TNComboBox.CMColorChanged(var Message: TMessage); begin inherited; FColumns.ColorChanged; end; procedure TNComboBox.CMFontChanged(var Message: TMessage); begin inherited; FColumns.FontChanged; end; procedure TNComboBox.CNDrawItem(var Message: TWMDrawItem); begin FEditDrawing := (Message.DrawItemStruct^.itemState and ODS_COMBOBOXEDIT)<>0; inherited; end; constructor TNComboBox.Create(AOwner: TComponent); begin inherited Create(AOwner); FColumns := TCBColumns.Create(Self); FColumns.Add; FBoundaryLine := TBoundaryLine.Create; FItems := TStringList.Create; fTargetCol := 0; FIndent := 2; { FCanEdit:= true; } ItemHeight := 15; FNormalColor := Color; FEnterColor := Color; FErrorColor := clRed; end; procedure TNComboBox.CreateParams(var Params: TCreateParams); begin inherited; Params.Style := Params.Style or CBS_OWNERDRAWFIXED; end; destructor TNComboBox.Destroy; begin FItems.Free; FBoundaryLine.Free; FColumns.Free; inherited; end; procedure TNComboBox.DoEnter; begin if (not FErrorOn) and (FColorChange) then Color := FEnterColor; inherited DoEnter; end; procedure TNComboBox.DoExit; begin FErrorOn := False; if (FColorChange) then Color := FNormalColor; inherited DoExit; end; procedure TNComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); var i, offset: Integer; rc : TRect; col : TCBColumn; strs : TStringList; clTmp : TColor; begin if FEditDrawing then begin Canvas.FillRect(Rect); Canvas.TextOut(Rect.Left + 2, Rect.Top + 2, GetSelectedText); end else begin Canvas.FillRect(Rect); strs := TStringList.Create; try strs.CommaText := FItems[Index]; offset := Rect.Left; for i := 0 to FColumns.Count - 1 do begin col := FColumns[i]; rc := Classes.Rect(offset, Rect.Top, offset + col.FWidth, Rect.Bottom); if rc.Right > Rect.Right then rc.Right := Rect.Right; // テキスト表示 if i >= strs.Count then col.DrawColumn(Self, rc, '', odSelected in State) else col.DrawColumn(Self, rc, strs[i], odSelected in State); // 境界線 if (i <> 0) and (FBoundaryLine.Drawing) then begin clTmp := Canvas.Pen.Color; Canvas.Pen.Color := FBoundaryLine.Color; Canvas.MoveTo(rc.Left, rc.Top); Canvas.LineTo(rc.Left, rc.Bottom); Canvas.Pen.Color := clTmp; end; // Inc(offset, col.FWidth); end; rc := Classes.Rect(offset, Rect.Top, Rect.Right, Rect.Bottom); Canvas.FillRect(rc); finally strs.Free; end; end; end; procedure TNComboBox.DropDown; var i, wid: Integer; begin inherited DropDown; wid := 0; for i := 0 to FColumns.Count - 1 do Inc(wid, FColumns[i].Width); SendMessage(Handle, CB_SETDROPPEDWIDTH, wid, 0); end; function TNComboBox.ColIndexOf(const col: Integer; const s: string): Integer; var strs: TStringList; rtn : Integer; i : Integer; begin strs := TStringList.Create; try for i := 0 to FItems.Count - 1 do strs.Add(GetColumnText(i, col)); rtn := strs.IndexOf(s); finally strs.Free; end; Result := rtn; end; function TNComboBox.GetColText(col: Integer): string; var i: Integer; begin for i := 0 to Items.Count - 1 do //2003.12.24 修正開始 // if AnsiPos(Text, Items[i]) <> 0 then Break; if AnsiPos(Text, FItems[i]) <> 0 then Break; //2003.12.24 修正終了 Result := GetColumnText(i, col); end; function TNComboBox.GetColumnText(idx, col: Integer): string; var strs: TStringList; begin Result := ''; if (idx < 0) or (fItems.Count <= idx) then Exit; strs := TStringList.Create; try strs.CommaText := fItems[idx]; if col < strs.Count then Result := strs.Strings[col]; finally strs.Free; end; end; function TNComboBox.GetSelectedText: string; begin // if CanEdit and LongBool(SendMessage(EditHandle, EM_GETMODIFY, 0, 0)) then if LongBool(SendMessage(EditHandle, EM_GETMODIFY, 0, 0)) then Result := Text else Result := GetColumnText(ItemIndex, FTargetCol); end; procedure TNComboBox.KeyPress(var Key: Char); var ParentForm: TCustomForm; begin Case Key of #13: // Enter begin if FEnterFocusMove then begin ParentForm := GetParentForm( Self ); // TFormが見つからない if ParentForm = nil then Exit; // 次コントロールへ移動 PostMessage( ParentForm.Handle, WM_NEXTDLGCTL, 0, 0 ); // キー無効 key := #0; end else begin // beep; // ビープ音を鳴らす。 end; // key := #0; // キー無効 end; end; inherited KeyPress(Key); end; procedure TNComboBox.KeyUp(var Key: Word; Shift: TShiftState); var TypedStr : String; i, TempLength: Integer; wkStr : String; TargetItems : TStringList; strs : TStringList; begin // スキップさせるキー case Key of VK_LEFT..VK_DOWN : Exit; // 矢印キー VK_BACK..VK_CLEAR : Exit; // 削除キー VK_SHIFT..VK_MENU : Exit; // Ctrl,Shift,Alt end; // 入力支援あり？ if (Not FInputSupport) then Exit; // ＩＭＥ入力対応 if (SelLength > 0) and (Key <> VK_RETURN) then Exit; TempLength := 0; TypedStr := text; TargetItems := TStringList.Create; strs := TStringList.Create; try // 探索用リスト作成 for i := 0 to FItems.Count - 1 do begin strs.CommaText:= FItems[i]; if FTargetCol < strs.Count then TargetItems.Add(strs[FTargetCol]) else TargetItems.Add(strs[0]); end; // 自動入力 for i := 0 to FItems.Count - 1 do begin if AnsiPos(TypedStr, TargetItems[i]) = 1 then begin wkStr := TargetItems[i]; TempLength := Length(TypedStr); Break; end; end; // 自動入力対象がなかった時 if wkStr = '' then exit; Text := wkStr; SelStart := TempLength; SelLength := Length(Text) - TempLength; finally Change; // OnChangeイベント発生 TargetItems.Free; strs.Free; inherited KeyUp(Key,Shift); end; end; procedure TNComboBox.SetBoundaryLine(AValue: TBoundaryLine); begin FBoundaryLine.Assign(AValue); end; procedure TNComboBox.SetColorChange(AValue: Boolean); begin if FColorChange <> AValue then FColorChange := AValue; end; procedure TNComboBox.SetColumns(columns: TCBColumns); begin FColumns.Assign(columns); end; procedure TNComboBox.SetEnterColor(AValue: TColor); begin if FEnterColor <> AValue then begin FEnterColor := AValue; if FNormalColor <> FEnterColor then FColorChange := True; end; end; procedure TNComboBox.SetEnterFocusMove(AValue: Boolean); begin if FEnterFocusMove <> AValue then FEnterFocusMove := AValue; end; procedure TNComboBox.SetErrorColor(AValue: TColor); begin if FErrorColor <> AValue then begin FErrorColor := AValue; Invalidate; end; end; procedure TNComboBox.SetErrorOn(AValue: Boolean); begin if FErrorOn <> AValue then begin FErrorOn := AValue; if FErrorOn then Color := FErrorColor else Color := FNormalColor; end; end; procedure TNComboBox.SetInputSupport(AValue: Boolean); begin if FInputSupport <> AValue then FInputSupport := AValue; end; procedure TNComboBox.SetNormalColor(AValue: TColor); begin if FNormalColor <> AValue then begin FNormalColor := AValue; Color := FNormalColor; Invalidate; end; end; { ------------------------------------------------------- } { TBoundaryLine の実装部 } { ------------------------------------------------------- } procedure TBoundaryLine.Assign(Source: TPersistent); begin if Source is TBoundaryLine then begin Drawing := TBoundaryLine(Source).Drawing; Color := TBoundaryLine(Source).Color; Exit; end; inherited Assign(Source); end; constructor TBoundaryLine.Create; begin inherited Create; FColor := clBlack; FDrawing := True; end; procedure TBoundaryLine.SetColor(col: TColor); begin if FColor <> col then FColor := col; end; procedure TBoundaryLine.SetDrawing(AValue: Boolean); begin if FDrawing <> AValue then FDrawing := AValue; end; { ------------------------------------------------------- } { TCBColumn の実装部 } { ------------------------------------------------------- } constructor TCBColumn.Create( Collection: TCollection); begin inherited Create( Collection); FWidth := 60; FFont := TFont.Create; FFont.OnChange := FontChanged; FParentColor := true; FParentFont := true; ParentColorChanged; ParentFontChanged; end; destructor TCBColumn.Destroy; begin FFont.Free; inherited; end; procedure TCBColumn.ParentColorChanged; begin if FParentColor then FColor := TCBColumns(Collection).fOwner.Color; end; procedure TCBColumn.ParentFontChanged; begin if FParentFont then FFont.Assign(TCBColumns(Collection).fOwner.Font); end; procedure TCBColumn.FontChanged( Sender: TObject); begin FParentFont := false; end; function TCBColumn.IsStoredColor: Boolean; begin Result := not FParentColor; end; function TCBColumn.IsStoredFont: Boolean; begin Result := not FParentFont; end; procedure TCBColumn.SetColor(AValue: TColor); begin if FColor <> AValue then begin FColor := AValue; FParentColor := false; end; end; procedure TCBColumn.SetFont(AValue: TFont); begin FFont.Assign(AValue); FParentFont := false; end; procedure TCBColumn.SetParentColor(AValue: Boolean); begin if FParentColor <> AValue then begin FParentColor := AValue; ParentColorChanged; end; end; procedure TCBColumn.SetParentFont(AValue: Boolean); begin if FParentFont <> AValue then begin FParentFont := AValue; ParentFontChanged; FParentFont := AValue; end; end; procedure TCBColumn.DrawColumn(Sender: TNComboBox; aRect: TRect; text: string; isSelected: Boolean); const alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER); var fontColor: TColor; begin with Sender.Canvas do begin if not isSelected then begin Brush.Color := FColor; Font := FFont; end else begin fontColor := Font.Color; Font := FFont; Font.Color := fontColor; end; FillRect(aRect); if FAlignment = taRightJustify then aRect.Right := aRect.Right - Sender.FIndent else if FAlignment = taLeftJustify then aRect.Left := aRect.Left + Sender.fIndent; DrawText(Handle, PChar(text), Length(text), aRect, DT_SINGLELINE or DT_VCENTER or alignments[fAlignment]); end; end; procedure TCBColumn.Assign(Source: TPersistent); begin if Source is TCBColumn then with TCBColumn(Source) do begin Width := Self.Width; Color := Self.Color; Alignment := Self.Alignment; Font := Self.Font; ParentColor := Self.ParentColor; ParentFont := Self.ParentFont; Exit; end; inherited Assign(Source); end; { ------------------------------------------------------- } { TCBColumns の実装部 } { ------------------------------------------------------- } constructor TCBColumns.Create(AOwner: TNComboBox); begin inherited Create(TCBColumn); FOwner := AOwner; end; procedure TCBColumns.ColorChanged; var i: Integer; begin for i := 0 to Count - 1 do Items[i].ParentColorChanged; end; procedure TCBColumns.FontChanged; var i: Integer; begin for i := 0 to Count - 1 do Items[i].ParentFontChanged; end; function TCBColumns.GetItem(idx: Integer): TCBColumn; begin Result := TCBColumn(inherited GetItem(idx)); end; function TCBColumns.GetOwner: TPersistent; begin Result := FOwner; end; procedure TCBColumns.SetItem(idx: Integer; item: TCBColumn); begin inherited SetItem(idx, item); end; { ------------------------------------------------------- } { TNStringGrid の実装部 } { ------------------------------------------------------- } constructor TNStringGrid.Create(AOwner: TComponent); begin inherited Create(AOwner); FSetCol := 0; FGetFixS := ''; FSortFlg := false; FSortUp := True; FSpacing := 10; DefaultRowHeight := 20; FGridColumns := TGridColumns.Create(Self); FRowParams := TRowParams.Create(Self); FMouseDown := False; FSaveBrush := TBrush.Create; FSavePen := TPen.Create; FSaveFont := TFont.Create; FStripeColor := Color; FStripeFont := TFont.Create; FGridStriped := False; FCellPadding := 2; FLayout := tlTop; FFixedAlignment := taLeftJustify; FFocusDraw := True; FFocusCellParam := False; FFocusCellColor := clHighlight; FFocusCellFont := TFont.Create; FFocusCellFont.Color := clHighlightText; FNowSortedCol := -1; DefaultDrawing := False; ColCount := 4; end; destructor TNStringGrid.Destroy; begin FGridColumns.Free; FRowParams.Free; FSaveBrush.Free; FSavePen.Free; FSaveFont.Free; FStripeFont.Free; FFocusCellFont.Free; inherited Destroy; end; procedure TNStringGrid.GridToCsv(AFileName: String); var Col, Row: Integer; tmpStr : String; tmpList : TStringList; begin tmpList := TStringList.Create; try tmpList.Clear; // ファイル名指定ありか if AFileName <> '' then begin { 外部 CSV ファイルへ保存 } // 行の終わりまで for Row := 0 to Self.RowCount - 1 do if Self.RowHeights[Row] <> -1 then tmpList.Add(Self.Rows[Row].CommaText); // 指定ファイル名で保存 tmpList.SaveToFile(AFileName); end else begin { ClipBoard へ保存 } // 行の終わりまで for Row := 0 to Self.RowCount - 1 do begin if Self.RowHeights[Row] <> -1 then begin tmpStr := ''; // 列の終わりまで for Col := 0 to Self.ColCount - 1 do begin if tmpStr <> '' then tmpStr := tmpStr + Char(VK_TAB) + Self.Cells[Col, Row] else tmpStr := Self.Cells[Col, Row]; end; tmpList.Add(tmpStr); end; end; // TMemo を介してクリップボードへ with TMemo.Create(GetParentForm(Self)) do begin try Name := 'tmpMemo1'; ParentWindow := Self.Handle; Lines.Clear; Lines.Assign(tmpList); SelectAll; CopyToClipboard; finally Free; end; end; end; finally tmpList.Free; end; end; procedure TNStringGrid.GridToCsv; begin GridToCsv(''); end; procedure TNStringGrid.SelectionCellsToCsv(AFileName: String); var Col, Row: Integer; x1, x2, y1, y2 : Integer; tmpStr : String; tmpList : TStringList; tmpList2: TStringList; begin // 選択範囲取得 with Self.Selection do begin x1 := Left; x2 := Right; y1 := Top; y2 := Bottom; end; tmpList := TStringList.Create; try tmpList.Clear; // ファイル名指定ありか if AFileName <> '' then begin tmpList2 := TStringList.Create; try for Row := y1 to y2 do begin tmpList2.Clear; for Col := x1 to x2 do tmpList2.Add(Self.Cells[Col, Row]); tmpList.Add(tmpList2.CommaText); end; finally tmpList2.Free; end; tmpList.SaveToFile(AFileName); end else begin for Row := y1 to y2 do begin tmpStr := ''; for Col := x1 to x2 do if tmpStr <> '' then tmpStr := tmpStr + Char(VK_TAB) + Self.Cells[Col, Row] else tmpStr := Self.Cells[Col, Row]; tmpList.Add(tmpStr); end; with TMemo.Create(GetParentForm(Self)) do begin try Name := 'tmpMemo1'; ParentWindow := Self.Handle; Lines.Clear; Lines.Assign(tmpList); SelectAll; CopyToClipboard; finally Free; end; end; end; finally tmpList.Free; end; end; procedure TNStringGrid.SelectionCellsToCsv; begin SelectionCellsToCsv(''); end; procedure TNStringGrid.SetColWidth(ACol: Integer); var ARow : Integer; wrkRow : Integer; wrkLength: Integer; maxLength: Integer; begin // 初期クリア maxLength := 0; wrkRow := 0; for ARow := 0 to RowCount - 1 do begin wrkLength := Length(Cells[ACol, ARow]); if wrkLength > maxLength then begin maxLength := wrkLength; wrkRow := ARow; end; end; // TCanvas を利用し必要ピクセル数算出 with Canvas do begin Font.Assign(Self.Font); ColWidths[ACol] := TextWidth(TrimRight(Cells[ACol, wrkRow])) + 4; end; end; procedure TNStringGrid.SetAllColWidth; var ACol: Integer; begin Rows[0].BeginUpdate; try for ACol := 0 to ColCount - 1 do SetColWidth(ACol); finally Rows[0].EndUpdate; end; end; procedure TNStringGrid.SetSpacing(Value: Integer); begin if FSpacing <> Value then FSpacing := Value; end; procedure TNStringGrid.UpdateScrollBar(Target: TScrollStyle); const DEFAULT_NMAX = 127; var SIOld, SINew : TScrollInfo; AColCount, ARowCount : integer; begin { スクロールバーのつまみの大きさの調整 本当は自動でやりたかったが、どうも無理そうなので手動に変更 グリッドのHeight,Widthが固定でない場合は不具合が出るので注意 } if not HandleAllocated then Exit; SIOld.cbSize := sizeof(SIOld); SIOld.fMask := SIF_ALL; if (Target in [ssVertical, ssBoth]) then begin ARowCount := RowCount - FixedRows; if (ScrollBars in [ssVertical, ssBoth]) and (Self.VisibleRowCount < ARowCount) then begin GetScrollInfo(Self.Handle, SB_VERT, SIOld); SINew := SIOld; SINew.nPage := (VisibleRowCount * 127) div (ARowCount - VisibleRowCount); SINew.nMax := DEFAULT_NMAX + SINew.nPage; SetScrollInfo(Self.Handle, SB_VERT, SINew, True); end; end; if (Target in [ssHorizontal, ssBoth]) then begin AColCount := ColCount - FixedCols; if (ScrollBars in [ssHorizontal, ssBoth]) and (Self.VisibleColCount < AColCount) then begin GetScrollInfo(Self.Handle, SB_HORZ, SIOld); SINew := SIOld; SINew.nPage := (VisibleColCount * 127) div (AColCount - VisibleColCount); SINew.nMax := DEFAULT_NMAX + SINew.nPage; SetScrollInfo(Self.Handle, SB_HORZ, SINew, True); end; end; end; procedure TNStringGrid.SetGridColumns(AValue: TGridColumns); begin Invalidate; end; function TNStringGrid.GetDisplayText(AText, ADisplayMask: string): string; var i : integer; flg: boolean; begin flg := true; for i := 1 to Length(AText) do if not (AText[i] in ['0'..'9', '.', '-', '+']) then flg := false; if flg then result := FormatFloat(ADisplayMask, StrToFloat(AText)) else // result := FormatMaskText(ADisplayMask, AText); end; function TNStringGrid.GetBrushColor(ACol, ARow: integer): TColor; var i : Integer; Param: TRowParam; begin // 行パラメータ優先 if FRowParams.Count > 0 then for i := 0 to FRowParams.Count - 1 do begin Param := FRowParams.Items[i]; if (Param.Enabled) and (((Param.RowMax = 0) and (ARow = Param.Row)) or ((Param.RowMax > 0) and (ARow >= Param.Row) and (ARow <= Param.RowMax))) then begin result := FRowParams.Items[i].Color; Exit; end; end; if GridStriped then if (ARow mod 2) <> 0 then result := Color else result := StripeColor else if ACol < FGridColumns.Count then result := FGridColumns.Items[ACol].Color else result := Color; end; procedure TNStringGrid.DrawFixedFrame(ARect: TRect); begin if Ctl3D then begin Canvas.Pen.Style := psSolid; Canvas.Pen.Mode := pmCopy; with ARect do begin Canvas.Pen.Color := clBtnHighlight; Canvas.MoveTo(Right - 1, Top); Canvas.LineTo(Left, Top); Canvas.LineTo(Left, Bottom - 1); Canvas.Pen.Color := clBtnShadow; Canvas.LineTo(Right - 1, Bottom - 1); Canvas.LineTo(Right - 1, Top); end; end; end; procedure TNStringGrid.DrawFixedFramePushed(ARect: TRect); begin if Ctl3D then begin Canvas.Pen.Style := psSolid; Canvas.Pen.Mode := pmCopy; with ARect do begin Canvas.Pen.Color := clBtnShadow; Canvas.MoveTo(Right - 1, Top); Canvas.LineTo(Left, Top); Canvas.LineTo(Left, Bottom - 1); Canvas.Pen.Color := clBtnHighlight; Canvas.LineTo(Right - 1, Bottom - 1); Canvas.LineTo(Right - 1, Top); end; end; end; procedure TNStringGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); var GridColumn: TGridColumn; Offset : integer; procedure DrawCellTextEx; //フォーカス枠描画 サブ手続き //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ procedure Sub_DrawFocusRect( ACellRect: TRect; ADrawLeft, ADrawRight: boolean ); //指定位置フォーカス色設定 サブ手続き //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ procedure Sub_Sub_SetFocusRectColor( ALeft, ATop: integer ); var nowcolor, frcolor: TColor; coldiff: longint; begin //フォーカス枠の色を反転して作成 nowcolor := Canvas.Pixels[ ALeft, ATop ]; frcolor := ( not nowcolor ) and $FFFFFF; //反転した結果、あまりに近い色であれば、作りなおし //（各色成分の違いの合計が 8*3=24 より少ない場合は近い色と判定） coldiff := Abs( ( nowcolor and $FF ) - ( frcolor and $FF ) ) + Abs( ( ( nowcolor shr 8 ) and $FF ) - ( ( frcolor shr 8 ) and $FF ) ) + Abs( ( ( nowcolor shr 16 ) and $FF ) - ( ( frcolor shr 16 ) and $FF ) ); if coldiff < 24 then begin if nowcolor > clSilver then frcolor := clBlack else frcolor := clWhite; end; Canvas.Pixels[ ALeft, ATop ] := frcolor; end; var i: integer; begin // フォーカス描画の確認（固定列はどうあってもフォーカスできないのよ） if ( FixedCols > ACol ) or ( FixedRows > ARow ) then exit; // キャンバス初期化 Canvas.Pen.Style := psSolid; Canvas.Brush.Style := bsSolid; // 描画範囲設定 ACellRect.Right := ACellRect.Right - 1; ACellRect.Bottom := ACellRect.Bottom - 1; // フォーカス枠を描く（１ドットおきに点） with ACellRect do begin // 横線 for i := 0 to ( Right - Left ) div 2 do begin Sub_Sub_SetFocusRectColor( Left + i * 2, Top ); Sub_Sub_SetFocusRectColor( Left + i * 2, Bottom ); end; // 縦線 for i := 1 to ( Bottom - Top - 1 ) div 2 do begin if ADrawLeft then Sub_Sub_SetFocusRectColor( Left, Top + i * 2 ); if ADrawRight then Sub_Sub_SetFocusRectColor( Right, Top + i * 2 ); end; end; end; var S : string; // t, drawT : string; Flags : integer; // i, j, x, y
←解決時は質問者本人がここをチェックしてください。
戻る
掲示板システム
Copyright 2021 Takeshi Okamoto All Rights Reserved.