Q: 怎么来改变ListBox的字体呢?就修改其中的一行。A: 先把ListBox1.Style 设成lbOwnerDrawFixed
然后在 OnDrawItem 事件下写下如下代码procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
Offset: Integer;
begin
Offset := 2;
with (Control as TListBox).Canvas do begin
FillRect(Rect);
if Index = 2 then begin
Font.Name := 'Fixedsys';
Font.Color := clRed;
Font.Size := 12;
end else begin
Font.Name := 'Arial';
Font.Color := clBlack;
Font.Size := 8;
end;
if odSelected in State then begin
Font.Color := clWhite;
end;
TextOut(Rect.Left + Offset, Rect.Top, (Control as TListBox).Items[Index]);
end;
end;
然后在 OnDrawItem 事件下写下如下代码procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
Offset: Integer;
begin
Offset := 2;
with (Control as TListBox).Canvas do begin
FillRect(Rect);
if Index = 2 then begin
Font.Name := 'Fixedsys';
Font.Color := clRed;
Font.Size := 12;
end else begin
Font.Name := 'Arial';
Font.Color := clBlack;
Font.Size := 8;
end;
if odSelected in State then begin
Font.Color := clWhite;
end;
TextOut(Rect.Left + Offset, Rect.Top, (Control as TListBox).Items[Index]);
end;
end;
解决方案 »
- stringgrid整行数据添加,删除的问题
- 把oracle的表和数据倒到sqlserver或access
- 为什么用Onkeypress方法确定用回车键时,一按回车键音箱就会有‘铛’的一声响?
- 一个小问题,在线等待,回复就给分
- 如何在tedit控件中添加printed属性
- 关于“字符旋转”的问题!???????????高分等待!!!在线
- 对SQL语句擅长的帮帮忙,关于优化SQL语句的问题,提点建议。在线等待,好的马上给发分。
- 我快风了!为何我现在不能进到我自己编的VCL代码中去?
- 为什么用 SystemParametersInfo 设置墙纸只会居中显示,平铺和拉伸都不行?
- TMNSMTP 控件發郵件出現錯誤'552message size of 3820846 bytes exceeds site limit of 2097152 bytes'如何解決?
- 小数点问题!
- sqlserver表内容如何插入paradox本地表??
var
FO: TShFileOpStruct;
begin
FillChar(FO,SizeOf(FO),#0);
FO.Wnd := Form1.Handle;
FO.wFunc := FO_DELETE;
FO.pFrom := PChar(Source);
ShFileOperation(FO);
end;procedure EmptyDirectory(Path: String);
begin
if DirectoryExists(Path) then
begin
DeleteFiles(Path+'\*');
end
else
ForceDirectories(Path);
end;
var
DriveNum: Integer;
DriveChar: Char;
DriveBits: set of 0..25;
StartSTr,TestStr: STring;
begin
result := UNCPath;
StartSTr := UNCPath;
Integer(DriveBits) := GetLogicalDrives;
for DriveNum := 0 to 25 do
begin
if (DriveNum in DriveBits) then begin
DriveChar := Char(DriveNum + Ord('A'));
TestSTr := ExpandUNCFileName(DriveChar+':\');
If TEstStr <> '' then
If Pos(Uppercase(TestSTr),Uppercase(STartSTr)) > 0 then
begin
Delete(StartSTr,1,Length(TestSTr));
result := DriveChar+':\'+StartSTr;
break;
end;
end;
end;
end;
* 我不想从EXE文件里面提取出来如果可能,请告诉我。因为,我的字体是自己做的不是windows自带的,我想保护自己的东西。A:不太可能,必须提取出来。你可以使用这个保护过程来保护你的文件不被修改和删除。在EXE执行的时候把字体放到临时文件夹里,结束的时候删除它。function ProtectFile(sFilename : string) : hFile;
var
hf: hFile;
lwHFileSize, lwFilesize: longword;
ofs : TOFStruct;
begin
if FileExists(sFilename) then
begin
hf := OpenFile(pchar(sFilename), ofs, OF_READ or OF_WRITE or OF_SHARE_EXCLUSIVE);
if hf <> 0 then
begin
lwFilesize := GetFileSize(hf, @lwHFileSize);
if LockFile(hf, 0, 0, lwFilesize, lwHFilesize) then
Result := hf else Result := 0;
end
else Result := 0;
end
else Result := 0;
end;//..
var
ResS: TResourceStream;
TempPath: array [0..MAX_PATH] of Char;
TempDir: string;
begin
GetTempPath(Sizeof(TempPath), TempPath);
TempDir := StrPas(Path);
ResS := TResourceStream.Create(hInstance, 'SOME_FONT', 'RT_FONT');
ResS.SavetoFile(TempDir+'some_font.ttf');
ResS.Free;
AddFontResource(TempDir+'some_font.ttf');
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
ProtectFile(TempDir+'some_font.ttf');
end;
var
reg:TRegistry;
begin
reg:=TRegistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion',false) then
begin
edit1.Text:=reg.ReadString('ProgramFilesDir');
reg.CloseKey;
reg.Free;
end;
end;
uses
Jpeg;procedure TForm1.Button1Click(Sender: TObject);
var
Bmp : TBitmap;
Jpg : TJpegImage;
begin
try
Bmp := TBitmap.Create;
Jpg := TjpegImage.Create;
Jpg.LoadFromFile('c:\img.jpg');
Bmp.Assign(Jpg);
Bmp.Canvas.Brush.Style := bsClear;
Bmp.Canvas.Font.Color := clYellow;
Bmp.Canvas.TextOut(10,10,'Hello World');
Jpg.Assign(Bmp);
Jpg.SaveToFile('c:\img2.jpg');
finally
bmp.Free;
jpg.Free;
end;
end;
now
Shift: TShiftState);
begin
if key=VK_F1 then
begin
DBGrid1.DataSource:=DataSource1;
ADOTable1.Active:=true;
ADOTable2.Active:=false;
end
else if key=VK_F2 then
begin
DBGrid1.DataSource:=DataSource2;
ADOTable2.Active:=true;
ADOTable1.Active:=false;
end
end ;case key of
vk_f11:
begin
end; if edit1.Text=ADOTable1.FieldByName('no').AsString then
begin
edit2.Text:=ADOTable1.FieldValues['pname'];
edit3.Text:=ADOTable1.FieldValues['kroom'];
edit4.Text:=ADOTable1.FieldValues['dname'];
end
DBGrid中如何让回车变为光标右移动
在Form.OnKeyPress事件中写如下代码:if Key = #13 then
if ActiveControl = DBGrid1 then begin
TDBGrid(ActiveControl).SelectedIndex := TDBGrid(ActiveControl).SelectedIndex + 1;
Key := #0;
end; 有2点需要注意:
1.当光标达到DBGird最右列的时候,再按回车,光标还会停留在原地。
2.Key := #0一句让光标移动到下一列以后处于浏览状态,如果去掉这行代码光标移动到下一列以后将处于编辑状态。
// indicates the file time to set, used by SetFileTimesHelper and SetDirTimesHelper
TFileTimes = (ftLastAccess, ftLastWrite, ftCreation);function SetFileTimesHelper(const FileName: string; const DateTime: TDateTime; Times: TFileTimes): Boolean;
var
Handle: THandle;
FileTime: TFileTime;
SystemTime: TSystemTime;
begin
Result := False;
Handle := CreateFile(PChar(FileName), GENERIC_WRITE, FILE_SHARE_READ, nil,
OPEN_EXISTING, 0, 0);
if Handle <> INVALID_HANDLE_VALUE then
try
//SysUtils.DateTimeToSystemTime(DateTimeToLocalDateTime(DateTime), SystemTime);
SysUtils.DateTimeToSystemTime(DateTime, SystemTime);
if Windows.SystemTimeToFileTime(SystemTime, FileTime) then
begin
case Times of
ftLastAccess:
Result := SetFileTime(Handle, nil, @FileTime, nil);
ftLastWrite:
Result := SetFileTime(Handle, nil, nil, @FileTime);
ftCreation:
Result := SetFileTime(Handle, @FileTime, nil, nil);
end;
end;
finally
CloseHandle(Handle);
end;
end;//--------------------------------------------------------------------------------------------------function SetFileLastAccess(const FileName: string; const DateTime: TDateTime): Boolean;
begin
Result := SetFileTimesHelper(FileName, DateTime, ftLastAccess);
end;//--------------------------------------------------------------------------------------------------function SetFileLastWrite(const FileName: string; const DateTime: TDateTime): Boolean;
begin
Result := SetFileTimesHelper(FileName, DateTime, ftLastWrite);
end;//--------------------------------------------------------------------------------------------------function SetFileCreation(const FileName: string; const DateTime: TDateTime): Boolean;
begin
Result := SetFileTimesHelper(FileName, DateTime, ftCreation);
end;
删掉程序自己的exe文件
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
F:TextFile;
begin
AssignFile(F,'delself.bat');
Rewrite(F);{F为TextFile类型}
WriteLn(F,'del '+ExtractFileName(Application.ExeName));
WriteLn(F,'del %0'); //删除自己delself.bat
CloseFile(F);
WinExec('delself.bat',SW_HIDE);
end;----------------------------------------------
ShowMessage('该位置字符是汉字');
汉字是双字节的
str: string;
begin
str := 'yyyy-mm-dd';
if SetLocaleInfoa(LOCALE_SYSTEM_DEFAULT, LOCALE_SLONGDATE, PChar(str)) then
begin
showmessage('更改日期格式成功');
end;
end;休息一分钟:
var
I:integer;
begin
i:=gettickcount;
while (Gettickcount-i)<=10000 do
application.ProcessMessages;//保证消息循环
end;
取主文件名:
function retuFileName(const FileName: string): string;
var
I: Integer;
begin
I := LastDelimiter('.', FileName);
Result := Copy(FileName, 1, i-1);end;