请问我如何在C++Builder6.0里使用Delphi5.0的 pas文件 ?(50分)

  • 主题发起人 主题发起人 葬月
  • 开始时间 开始时间

葬月

Unregistered / Unconfirmed
GUEST, unregistred user!
我在以前的tools.pas文件有许多定义的函数
我想在C++Builder里面使用,当我在菜单里 Add To Project后
然后在菜单后Include Unit hdr...这个tools,
这时候cpp文件出现 #include "tools.hpp" //这个tools.pas是在同一目录
但是编译时候就说不能打开 tools.hpp
我把tools.hpp改为 tools.pas,也出错,
怎么回事?
这个是我的tools.pas的内容
虽然和tools.pas的不相关,
unit tools;
interface
uses windows,Forms,mmsystem,winsock,sysutils,classes,controls,messages,activex,
shlobj,menus,comobj,jpeg,graphics,extctrls,ShellApi,contnrs,dialogs;
const
SHFMT_ID_DEFAULT = $FFFF;
// Formating options
SHFMT_OPT_QUICKFORMAT = $0000;
// Quick format
SHFMT_OPT_FULL = $0001;
// Full format
SHFMT_OPT_SYSONLY = $0002;
// Translate system file
SHFMT_ERROR = $FFFFFFFF;
// Error codes
SHFMT_CANCEL = $FFFFFFFE;
SHFMT_NOFORMAT = $FFFFFFFD;
const
FREQ_SCALE=$1193180;
RSP_HIDE=1;
RSP_SHOW=0;
const
MAX_PROTOCOL_CHAIN=7;
WSAPROTOCOL_LEN=255;
type WSAPROTOCOLCHAIN =record
ChainLen:integer;
ChainEntries:array[0..MAX_PROTOCOL_CHAIN] of dword;
end;

type
WSAPROTOCOL_INFOW =record
dwServiceFlags1:dword;
dwServiceFlags2:dword;
dwServiceFlags3:dword;
dwServiceFlags4:dword;
dwProviderFlags:dword;
ProviderId:TGUID;
dwCatalogEntryId:dword;
ProtocolChain:WSAPROTOCOLCHAIN;
iVersion:integer;
iAddressFamily:integer;
iMaxSockAddr:integer;
iMinSockAddr:integer;
iSocketType:integer;
iProtocol:integer;
iProtocolMaxOffset:integer;
iNetworkByteOrder:integer;
iSecurityScheme:integer;
dwMessageSize:dword;
dwProviderReserved:dword;
szProtocol:array[0..WSAPROTOCOL_LEN+1] of char;
end;

type
PPASSWORD_CACHE_ENTRY=^TPASSWORD_CACHE_ENTRY;
TPASSWORD_CACHE_ENTRY=packed record
cbEntry: word;
//password entry的字节长度
cbResource: word;
//resource name的字节长度
cbPassword: word;
//password的字节长度
iEntry: byte;
//entry index
nType: byte;
//type of entry
abResource : array[0..200] of char;
//start of resource name
//password immediately follows resource name
end;

const
CCH_MAXNAME=255;
LNK_RUN_MIN=7;
LNK_RUN_MAX=3;
LNK_RUN_NORMAL=1;
type LINK_FILE_INFO=record ///快捷方式文件信息数据结构
FileName:array[0..MAX_PATH] of char;
///目标文件名
WorkDirectory:array[0..MAX_PATH] of char;
///工作目录
IconLocation:array[0..MAX_PATH] of char;
///图标文件
IconIndex:integer;
///图标索引
Arguments:array[0..MAX_PATH] of char;
///运行参数
Description:array[0..CCH_MAXNAME] of char;
///文件描述
ItemIDList:PItemIDList;
///系统IDList,未使用
RelativePath:array[0..255] of char;///相对路径
ShowState:integer;
///运行时的现实状态
HotKey:word;
///热键
end;

const
FILE_CREATE_TIME=0;
///文件建立时间
FILE_MODIFY_TIME=1;
///修改时间
FILE_ACCESS_TIME=2;
///最后访问时间,不过好像总是当前时间?
const
RAS_MaxDeviceType = 16;//设备类型名称长度
RAS_MaxEntryName = 256;//连接名称最大长度
RAS_MaxDeviceName = 128;//设备名称最大长度
RAS_MaxIpAddress = 15;//IP地址的最大长度
RASP_PppIp = $8021;//拨号连接的协议类型,该数值表示PPP连接
type
HRASCONN = DWORD;//拨号连接句柄的类型
RASCONN = record//活动的拨号连接的句柄和设置信息
dwSize : DWORD;//该结构所占内存的大小(Bytes),一般设置为SizeOf(RASCONN)
hrasconn : HRASCONN;//活动连接的句柄
szEntryName : array[0..RAS_MaxEntryName] of char;//活动连接的名称
szDeviceType : array[0..RAS_MaxDeviceType] of char;//活动连接的所用的设备类型
szDeviceName : array[0..RAS_MaxDeviceName] of char;//活动连接的所用的设备名称
end;

type
TRASPPPIP = record//活动的拨号连接的动态IP地址信息
dwSize : DWORD;//该结构所占内存的大小(Bytes),一般设置为SizeOf(TRASPPPIP)
dwError : DWORD;//错误类型标识符
szIpAddress : array[ 0..RAS_MaxIpAddress ] of char;//活动的拨号连接的IP地址
end;

///下面定义查找文件的回调函数
type
TFindCallBack=procedure (const filename:string;const info:TSearchRec;var bQuit,bSub:boolean);
///下面是函数的接口
///使PC喇叭发声的函数,即使在Win9x下也可以,在NT中,请使用Windows.Beep(N1,N2)函数
procedure BeepEx(const feq:word=1200;const delay:word=1);
///延时函数
procedure Delay(const uDelay:dword);
///运行的时候拖动一个控件
procedure DragControl(aControl:TWincontrol);
///显示最近的操作的系统错误信息
procedure ShowErrorMessage;
///取得系统缓存的密码,好像用于拨号的
procedure GetCachedPassword(var buf:tstringlist);
///转换JPG到BMP格式
procedure JPG2BMP(const Source,Dest:string);
///转换BMP到JPG格式
procedure Bmp2Jpg(const Source,Dest:string;const scale:byte);
///FitBitmap很有用的,用来把一个图片大小改变!
procedure FitBitmap(const Source,Dest:string;const x,y:integer;const ColorBit:TPixelFormat);
///调用这个函数的程序在退出之后会自动删除Exe!
procedure DeleteMe;
///查找文件函数
procedure FindFile(var quit:boolean;const path: String;const filename:string='*.*';
proc:TFindCallBack=nil;bSub:boolean=true;const bMsg:boolean=true);
///设置分辨率
procedure SetRes(XRes, YRes: DWord);
procedure showinfo(msg:string);
///监测声卡是否存在
function SoundCardExist:boolean;
///执行一个外部程序,并且等待他的结束
Function WinExecExW(cmd,workdir:pchar;visiable:integer):DWORD;
///这个函数用在Win9x下面,可以使程序从Ctrl+Alt+Del中消失
function RegisterServiceProcess(const pid:longint;const b:longint):dword;stdcall;
///用于拨号的
function WSAEnumProtocols(lpiProtocols:integer;var lpProtocolBuffer:WSAPROTOCOL_INFOW;lpdwBufferLength:dword):integer;
///取得本机的IP地址
function GetLocalIP:string;
///从一个字符串中取得所有的数字
function GetNumFromStr(const str: String;const hex:boolean=false): String;
///分割一个字符串,其中分割的标志是ch
function SplitString(const source,ch:string):tstrings;
///读取或者写入快捷方式文件
function LinkFileInfo(const lnkFileName:string;var info:LINK_FILE_INFO;const bSet:boolean=false):boolean;
///把快捷键变成一个字符串
function ShortCutToString(const HotKey:word):string;
///创建一个快捷方式
function CreateLinkFile(const info:LINK_FILE_INFO;const DestFileName:string=''):boolean;
///生成语言ID,不过有错误,没有测试
function MakeLangID(const p,s:word):word;
///生成本地语言ID,也有错误?
function MakeLCID(const lgid,srtid:word):dword;
///运行一个DOS程序,并且取得他的输出
function RunDOS(const Prog, CommandLine,Dir: String;var ExitCode:DWORD): String;
///一个取Cache密码的函数,不过已经无效了
function WNetEnumCachedPasswords(para0: pointer;
para1:word;
para2: byte;
para3:pointer;
para4: dword): word;
stdcall;
///取的汉字的拼音的首字母
function GetHzPy(const AHzStr: string): string;
///转换Ansi到Unicode
function AnsiToUnicode(Ansi: string):string;
///转换Unicode到Ansi
function UnicodeToAnsi(Unicode: string):string;
///检测文件是否正在被使用
function IsFileInUse(fName : string ) : boolean;
///获取文件的时间信息
function GetFileLastAccessTime(sFileName:string;uFlag:byte=FILE_MODIFY_TIME):TDateTime;
///获取拨号连接
function RasEnumConnections( var lprasconn : RASCONN ;var lpcb: DWORD;var lpcConnections : DWORD) : DWORD;
stdcall;
function RasGetProjectionInfo(hrasconn : HRasConn;rasprojection : DWORD;var lpprojection : TRASPPPIP;var lpcb : DWord) : DWORD;stdcall;
function InternetGetConnectedState(uflag:dword;reverse:dword):boolean;stdcall;
function InetIsOffline(res:dword=0):boolean;stdcall;
///位操作
function GetBit(const x:dword;const bit:byte):dword;
///打开方式对话框
function OpenWith(h:hwnd;const filename:string):integer;
///关闭系统对话框
function SHShutDownDialog(h:integer):longint;
///格式化磁盘对话框
function SHFormatDrive(Handle: HWND;
Drive, ID, Options: Word):LongInt;stdcall;
///更改图标对话框
function SHChangeIconDialog(h:hwnd;filename:pchar;
Reserved:integer;var index:integer):integer;stdcall;
///运行对话框
function SHRunDialog(h:hwnd;rev1:dword;rev2:dword=0;szTitle:pchar=nil;szPrompt:Pchar=nil;uFlag:dword=0):dword;stdcall;
///打开方式
function OpenAs_RunDLL(const h:hwnd;b:hwnd;const filename:pchar;sw:integer=SW_SHOW):integer;stdcall;
///API的打开文件对话框,支持Win2000风格
function GetFileName(const filename:string):string;
function PackFileName(const fn: string;const len:integer=67) : string;
function StringRight(s:string;count:integer;ch:char=#0):string;
function Stringleft(s:string;count:integer;ch:char=#0):string;
function Rightpos(s:string;ch:char;count:integer=1):integer;
///生成一个GUID
function GetGUID:string;
///改正的选择目录对话框
function SelectDirectory(handle:hwnd;const Caption: string;
const Root: WideString;out Directory: string): Boolean;
///文件属性对话框
function SHFilePropertiesDialog(handle:hwnd;uFlags:Dword;Filename:pchar;str:pchar):dword;stdcall;
function SelectFile(handle:hwnd;Filename:pchar;sbsize:dword;initdir:pchar;fileext:pchar;filter:pchar;caption:pchar):integer;stdcall;
implementation
function SelectFile;external 'shell32.dll' index 63;
function SHFilePropertiesDialog;external 'shell32.dll' index 178;
function OpenAs_RunDLL;stdcall;external 'shell32.dll';
function SHShutDownDialog;external 'shell32.dll' index 60;
function SHRunDialog;stdcall;external 'shell32.dll' index 61;
function SHChangeIconDialog;external 'shell32.dll' index 62;
function SHFormatDrive;external 'shell32.dll' name 'SHFormatDrive';
function InetIsOffline;stdcall;external 'url.dll' name 'InetIsOffline';
function InternetGetConnectedState;stdcall;external 'wininet.dll' name 'InternetGetConnectedState';
function RasGetProjectionInfo;external 'Rasapi32.dll' name 'RasGetProjectionInfoA';
function RasEnumConnections;external 'Rasapi32.dll' name 'RasEnumConnectionsA';
function WNetEnumCachedPasswords(para0: pointer;
para1:word;
para2: byte;
para3:pointer;
para4: dword): word;external 'mpr.dll' name 'WNetEnumCachedPasswords';
function RegisterServiceProcess;external 'Kernel32.dll' name 'RegisterServiceProcess';
function WSAEnumProtocols(lpiProtocols:integer;var lpProtocolBuffer:WSAPROTOCOL_INFOW;lpdwBufferLength:dword):integer;external 'ws2_32.dll' name 'WSAEnumProtocolsA';
function SoundCardExist:boolean;
begin
result:=WaveOutGetNumDevs >0;
end;

procedure Delay(const uDelay:dword);
var
n:dword;
begin
n:=GetTickCount;
while ((GetTickCount-n)<=uDelay)do
application.ProcessMessages;
end;

procedure BeepEx(const feq:word=1200;const delay:word=1);
procedure BeepOff;
begin
asm
in al,$61;
and al,$fc;
out $61,al;
end;
end;

var
temp:word;
begin
temp:=FREQ_SCALE div feq;
asm
in al,61h;
or al,3;
out 61h,al;
mov al,$b6;
out 43h,al;
mov ax,temp;
out 42h,al;
mov al,ah;
out 42h,al;
end;
sleep(delay);
beepoff;
end;

procedure ShowErrorMessage;
var
errno:integer;
buf:array [0..255] of char;
begin
errno:=GetLastError;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,errno,$400,buf,255,nil);
if buf<>'' then
messagebox(application.handle,pchar(string(buf)+#13+'错误代号:'+inttostr(errno)+'。'),
'信息',MB_OK+MB_ICONINFORMATION);
end;

Function WinExecExW(cmd,workdir:pchar;visiable:integer):DWORD;
var
StartupInfo:TStartupInfo;
ProcessInfo:TProcessInformation;
begin
FillChar(StartupInfo,SizeOf(StartupInfo),#0);
StartupInfo.cb:=SizeOf(StartupInfo);
StartupInfo.dwFlags:=STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow:=visiable;
if not CreateProcess(nil,cmd,nil,nil,false,Create_new_console or Normal_priority_class,nil,nil,StartupInfo,ProcessInfo) then
result:=0
else
begin
waitforsingleobject(processinfo.hProcess,INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess,Result);
end;
end;

function GetLocalIP:string;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe : PHostEnt;
pptr : PaPInAddr;
Buffer : array [0..63] of char;
I : Integer;
GInitData : TWSADATA;
begin
WSAStartup($101, GInitData);
Result := '';
GetHostName(Buffer, SizeOf(Buffer));
phe :=GetHostByName(buffer);
if phe = nil then
Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^ <> nildo
begin
result:=StrPas(inet_ntoa(pptr^^));
Inc(I);
end;
WSACleanup;
end;

function GetNumFromStr(const str: String;const hex:boolean=false): String;
var
i:integer;
charset:Set of char;
begin
if hex then
charset:=['0'..'9','a'..'f','A'..'F','.']
else
charset:=['0'..'9','.'];
for i := 1 to Length(str)do
begin
if (str in charset) then
result:= result + uppercase(str);
end;
end;

function SplitString(const source,ch:string):tstrings;
var
temp:string;
i:integer;
begin
result:=tstringlist.Create;
temp:=source;
i:=pos(ch,source);
while i<>0do
begin
result.Add(copy( temp,0,i-1));
delete(temp,1,i);
i:=pos(ch,temp);
end;
result.Add(temp);
end;

procedure DragControl(aControl:TWincontrol);
const sc_dragmove=$f012;
begin
releasecapture;
acontrol.Perform(wm_syscommand,sc_dragmove,0);
end;

function LinkFileInfo(const lnkFileName:string;var info:LINK_FILE_INFO;const bSet:boolean):boolean;
var
hr:hresult;
psl:IShelllink;
wfd:win32_find_data;
ppf:IPersistFile;
lpw:pwidechar;
buf:pwidechar;
begin
result:=false;
getmem(buf,MAX_PATH);
try
if SUCCEEDED(CoInitialize(nil)) then
if (succeeded(cocreateinstance(clsid_shelllink,nil,clsctx_inproc_server,IID_IShellLinkA,psl))) then
begin
hr:=psl.QueryInterface(iPersistFile,ppf);
if succeeded(hr) then
begin
lpw:=stringtowidechar(lnkfilename,buf,MAX_PATH);
hr := ppf.Load(lpw, STGM_READ);
if succeeded(hr) then
begin
hr := psl.Resolve(0, SLR_NO_UI);
if succeeded(hr) then
begin
if bSet then
begin
psl.SetArguments(info.Arguments);
psl.SetDescription(info.Description);
psl.SetHotkey(info.HotKey);
psl.SetIconLocation(info.IconLocation,info.IconIndex);
psl.SetIDList(info.ItemIDList);
psl.SetPath(info.FileName);
psl.SetShowCmd(info.ShowState);
psl.SetRelativePath(info.RelativePath,0);
psl.SetWorkingDirectory(info.WorkDirectory);
if succeeded(psl.Resolve(0,SLR_UPDATE)) then
result:=true;
end
else
begin
psl.GetPath(info.FileName,MAX_PATH, wfd,SLGP_SHORTPATH );
psl.GetIconLocation(info.IconLocation,MAX_PATH,info.IconIndex);
psl.GetWorkingDirectory(info.WorkDirectory,MAX_PATH);
psl.GetDescription(info.Description,CCH_MAXNAME);
psl.GetArguments(info.Arguments,MAX_PATH);
psl.GetHotkey(info.HotKey);
psl.GetIDList(info.ItemIDList);
psl.GetShowCmd(info.ShowState);
result:=true;
end;
end;
end;
end;
end;
finally
freemem(buf);
end;
end;

function ShortCutToString(const HotKey:word):string;
var
shift:tshiftstate;
begin
shift:=[];
if ((wordrec(HotKey).hi shr 0) and 1)<>0 then
include(shift,ssshift);
if ((wordrec(HotKey).hi shr 1) and 1)<>0 then
include(shift,ssctrl);
if ((wordrec(HotKey).hi shr 2) and 1)<>0 then
include(shift,ssalt);
result:=shortcuttotext(shortcut(wordrec(hotkey).lo,shift));
end;

function CreateLinkFile(const info:LINK_FILE_INFO;const DestFileName:string=''):boolean;
var
anobj:IUnknown;
shlink:IShellLink;
pFile:IPersistFile;
wFileName:widestring;
begin
wFileName:=destfilename;
anobj:=CreateComObject(CLSID_SHELLLINK);
shlink:=anobj as IShellLink;
pFile:=anobj as IPersistFile;
shlink.SetPath(info.FileName);
shlink.SetWorkingDirectory(info.WorkDirectory);
shlink.SetDescription(info.Description);
shlink.SetArguments(info.Arguments);
shlink.SetIconLocation(info.IconLocation,info.IconIndex);
// shlink.SetIDList(info.ItemIDList);
shlink.SetHotkey(info.HotKey);
shlink.SetShowCmd(info.ShowState);
shlink.SetRelativePath(info.RelativePath,0);
if DestFileName='' then
wFileName:=ChangeFileExt(info.FileName,'lnk');
result:=succeeded(pFile.Save(pwchar(wFileName),false));
end;

function MakeLangID(const p,s:word):word;
begin
result:=word((word(s)) shl 10) or (word(p));
end;

function MakeLCID(const lgid,srtid:word):dword;
begin
result:=dword(((dword(word(srtid))) shl 16) or (dword(word(lgid))));
end;

function RunDOS(const Prog, CommandLine,Dir: String;var ExitCode:DWORD): String;
procedure CheckResult(b: Boolean);
begin
if not b then
Raise Exception.Create(SysErrorMessage(GetLastError));
end;

var
HRead,HWrite:THandle;
StartInfo:TStartupInfo;
ProceInfo:TProcessInformation;
b:Boolean;
sa:TSecurityAttributes;
inS:THandleStream;
sRet:TStrings;
begin
Result := '';
FillChar(sa,sizeof(sa),0);
//设置允许继承,否则在NT和2000下无法取得输出结果
sa.nLength := sizeof(sa);
sa.bInheritHandle := True;
sa.lpSecurityDescriptor := nil;
b := CreatePipe(HRead,HWrite,@sa,0);
CheckResult(b);
FillChar(StartInfo,SizeOf(StartInfo),0);
StartInfo.cb := SizeOf(StartInfo);
StartInfo.wShowWindow := SW_SHOW;
//使用指定的句柄作为标准输入输出的文件句柄,使用指定的显示方式
StartInfo.dwFlags := STARTF_USESTDHANDLES+STARTF_USESHOWWINDOW;
StartInfo.hStdError := HWrite;
StartInfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE);//HRead;
StartInfo.hStdOutput := HWrite;
b := CreateProcess(PChar(Prog),PChar(CommandLine),nil,nil,True,CREATE_NEW_CONSOLE,nil,PChar(Dir),StartInfo,ProceInfo);
CheckResult(b);
WaitForSingleObject(ProceInfo.hProcess,INFINITE);
GetExitCodeProcess(ProceInfo.hProcess,ExitCode);
inS := THandleStream.Create(hread);
if inS.Size>0 then
begin
sRet := TStringList.Create;
sRet.LoadFromStream(inS);
Result := sRet.Text;
sRet.Free;
end;
inS.Free;
CloseHandle(HRead);
CloseHandle(HWrite);
end;

procedure GetCachedPassword(var buf:tstringlist);
function pce(x:PPASSWORD_CACHE_ENTRY;y:dword):boolean;stdcall;
var
buffer1:array [0..200] of char;
begin
move(x.abResource,buffer1,x.cbResource);
if x.cbResource<50 then
fillchar(buffer1[x.cbResource],50-x.cbResource,#32);
move(x.abResource[x.cbResource],buffer1[50],x.cbPassword);
buffer1[x.cbPassword+50]:=#0;
buf.Add(buffer1);
Result:=true;
end;

begin
buf:=tstringlist.Create;
buf.Clear;
WNetEnumCachedPasswords(nil,0,255,@pce,0);
end;

function GetHzPy(const AHzStr: string): string;
const
ChinaCode: array[0..25, 0..1] of Integer = ((1601, 1636), (1637, 1832), (1833, 2077),
(2078, 2273), (2274, 2301), (2302, 2432), (2433, 2593), (2594, 2786), (9999, 0000),
(2787, 3105), (3106, 3211), (3212, 3471), (3472, 3634), (3635, 3722), (3723, 3729),
(3730, 3857), (3858, 4026), (4027, 4085), (4086, 4389), (4390, 4557), (9999, 0000),
(9999, 0000), (4558, 4683), (4684, 4924), (4925, 5248), (5249, 5589));
var
i, j, HzOrd: integer;
begin
i := 1;
while i <= Length(AHzStr)do
begin
if (AHzStr >= #160) and (AHzStr[i + 1] >= #160) then
begin
HzOrd := (Ord(AHzStr) - 160) * 100 + Ord(AHzStr[i + 1]) - 160;
for j := 0 to 25do
begin
if (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) then
begin
Result := Result + char(byte('A') + j);
break;
end;
end;
Inc(i);
end else
Result := Result + AHzStr;
Inc(i);
end;
end;

function AnsiToUnicode(Ansi: string):string;
var
s:string;
i:integer;
j,k:string[2];
a:array [1..1000] of char;
begin

s:='';
StringToWideChar(Ansi,@(a[1]),500);
i:=1;
while ((a<>#0) or (a[i+1]<>#0))do
begin

j:=IntToHex(Integer(a),2);
k:=IntToHex(Integer(a[i+1]),2);
s:=s+k+j;
i:=i+2;
end;

Result:=s;
end;

function UnicodeToAnsi(Unicode: string):string;
var
s:string;
i:integer;
j,k:string[2];
function ReadHex(AString:string):integer;
begin
Result:=StrToInt('$'+AString)
end;

begin
i:=1;
s:='';
while i<Length(Unicode)+1do
begin
j:=Copy(Unicode,i+2,2);
k:=Copy(Unicode,i,2);
i:=i+4;
s:=s+Char(ReadHex(j))+Char(ReadHex(k));
end;
if s<>'' then
s:=WideCharToString(PWideChar(s+#0#0#0#0))
else
s:='';
Result:=s;
end;

procedure FitBitmap(const Source,Dest:string;const x,y:integer;const ColorBit:TPixelFormat);
var
abmp,bbmp:tbitmap;
scalex,scaley:real;
begin
abmp:=tbitmap.Create;
bbmp:=tbitmap.Create;
try
abmp.LoadFromFile(Source);
scaley:=abmp.Height/y;
scalex:=abmp.Width/x;
bbmp.Width:=round(abmp.Width/scalex);
bbmp.Height:=round(abmp.Height/scaley);
bbmp.PixelFormat:=pf8bit;
SetStretchBltMode(bbmp.Canvas.Handle,COLORONCOLOR);
stretchblt(bbmp.Canvas.Handle,0,0,bbmp.Width,bbmp.Height,abmp.Canvas.Handle,0,0,abmp.Width,abmp.Height,srccopy);
bbmp.SaveToFile(Dest);
finally
abmp.Free;
bbmp.Free;
end;
end;

procedure Jpg2Bmp(const source,dest:string);
var
MyJpeg: TJpegImage;
bmp: Tbitmap;
begin
bmp:=tbitmap.Create;
MyJpeg:= TJpegImage.Create;
try
myjpeg.LoadFromFile(source);
bmp.Assign(myjpeg);
bmp.SaveToFile(dest);
finally
bmp.free;
myjpeg.Free;
end;
end;

procedure Bmp2Jpg(const source,dest:string;const scale:byte);
var
MyJpeg: TJpegImage;
Image1: TImage;
begin
Image1:= TImage.Create(application);
MyJpeg:= TJpegImage.Create;
try
Image1.Picture.Bitmap.LoadFromFile(source);
MyJpeg.Assign(Image1.Picture.Bitmap);
MyJpeg.CompressionQuality:=scale;
MyJpeg.Compress;
MyJpeg.SaveToFile(dest);
finally
image1.free;
myjpeg.Free;
end;
end;

function IsFileInUse(fName : string ) : boolean;
var
HFileRes : HFILE;
begin

Result := false;
if not FileExists(fName) then
exit;
HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE,0, nil, OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL, 0);
Result := (HFileRes = INVALID_HANDLE_VALUE);
if not Result then

CloseHandle(HFileRes);
end;

function GetFileLastAccessTime(sFileName:string;uFlag:byte):TDateTime;
var
ffd:TWin32FindData;
dft:DWord;
lft:TFileTime;
h:THandle;
begin
h:=FindFirstFile(PChar(sFileName),ffd);
if h<>INVALID_HANDLE_VALUE then
begin
case uFlag of
FILE_CREATE_TIME:FileTimeToLocalFileTime(ffd.ftCreationTime,lft);
FILE_MODIFY_TIME:FileTimeToLocalFileTime(ffd.ftLastWriteTime,lft);
FILE_ACCESS_TIME:FileTimeToLocalFileTime(ffd.ftLastAccessTime,lft);
else
FileTimeToLocalFileTime(ffd.ftLastAccessTime,lft);
end;
FileTimeToDosDateTime(lft,LongRec(dft).Hi,LongRec(dft).Lo);
Result:=FileDateToDateTime(dft);
windows.FindClose(h);
end
else
result:=0;
end;

procedure DeleteMe;
var
BatchFile: TextFile;
BatchFileName: string;
ProcessInfo: TProcessInformation;
StartUpInfo: TStartupInfo;
begin
BatchFileName := changefileext(paramstr(0),'.bat');
AssignFile(BatchFile, BatchFileName);
Rewrite(BatchFile);
Writeln(BatchFile, ':try');
Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
Writeln(BatchFile, 'if exist "' + ParamStr(0) + '"' + ' goto try');
Writeln(BatchFile, 'del %0');
CloseFile(BatchFile);
FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
StartUpInfo.wShowWindow := SW_HIDE;
if CreateProcess(nil, PChar(BatchFileName), nil, nil,False, IDLE_PRIORITY_CLASS,
nil, nil, StartUpInfo,ProcessInfo) then
begin
CloseHandle(ProcessInfo.hThread);
CloseHandle(ProcessInfo.hProcess);
end;
end;

procedure FindFile(var quit:boolean;const path: String;const filename:string='*.*';
proc:TFindCallBack=nil;bSub:boolean=true;const bMsg:boolean=true);
var
fpath: String;
info: TsearchRec;
procedure ProcessAFile;
begin
if (info.Name<>'.') and (info.Name<>'..') and ((info.Attr and faDirectory)<>faDirectory) then
begin
if assigned(proc) then
proc(fpath+info.FindData.cFileName,info,quit,bsub);
end;
end;

procedure ProcessADirectory;
begin
if (info.Name<>'.') and (info.Name<>'..') and ((info.attr and fadirectory)=fadirectory) then
findfile(quit,fpath+info.Name,filename,proc,bsub,bmsg);
end;

begin
if path[length(path)]<>'/' then
fpath:=path+'/'
else
fpath:=path;
try
if 0=findfirst(fpath+filename,faanyfile and (not fadirectory),info) then
begin
ProcessAFile;
while 0=findnext(info)do
begin
ProcessAFile;
if bmsg then
application.ProcessMessages;
if quit then
begin
findclose(info);
exit;
end;
end;
end;
finally
findclose(info);
end;
try
if bsub and (0=findfirst(fpath+'*',faanyfile,info)) then
begin
ProcessADirectory;
while findnext(info)=0do
ProcessADirectory;
end;
finally
findclose(info);
end;
end;

function GetBit(const x:dword;const bit:byte):dword;
begin
result:=(x shr (bit-1)) and 1;
end;

function SetBit(const x:dword;const bit:byte):dword;
begin
result:=x or (1 shr (bit-1));
end;

function OpenWith(h:hwnd;const filename:string):integer;
begin
result:=ShellExecute(h,'open','rundll32.exe',pchar('shell32.dll,OpenAs_RunDLL '+filename),'',sw_show);
end;

procedure SetRes(XRes, YRes: DWord);
var
lpDevMode : TDeviceMode;
begin
lpDevMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;
lpDevMode.dmPelsWidth:=XRes;
lpDevMode.dmPelsHeight:=YRes;
ChangeDisplaySettings(lpDevMode, 0);
end;

function GetFileName(const filename:string):string;
begin
result:=changefileext(Extractfilename(filename),'');
end;

function Rightpos(s:string;ch:char;count:integer=1):integer;
var
i,n:integer;
begin
n:=0;
for i:=length(s)do
wnto 1do
begin
if s=ch then
inc(n);
if n=count then
break;
end;
result:=i;
end;

function PackFileName(const fn: string;const len:integer=67) : string;
var
name,path,drv:string;
buf:array [0..MAX_PATH] of char;
begin
result:=expandfilename(fn);
if (len>=length(result)) then
exit;
name:=extractfilename(result);
drv:=extractfiledrive(result);
path:=copy(extractfilepath(result),3,length(result)-3);
if length(name)>len-7 then
begin
getshortpathname(pchar(fn),buf,MAX_PATH);
name:=extractfilename(buf);
result:=drv+path+name;
if length(result)<len then
exit;
end;
repeat
delete(path,rightpos(path,'/',2),length(path)-rightpos(path,'/',2));
result:=drv+path+'.../'+name;
until length(result)<=len;
end;

function stringRight(s:string;count:integer;ch:char=#0):string;
begin
if ch=#0 then
begin
result:=copy(s,length(s)-count+1,count);
exit;
end;
result:=copy(s,rightpos(s,ch)+1,length(s)-rightpos(s,ch));
end;

function stringleft(s:string;count:integer;ch:char=#0):string;
begin
if ch=#0 then
result:=copy(s,1,count)
else
result:=copy(s,1,pos(ch,s)-1);
end;

procedure showinfo(msg:string);
begin
application.MessageBox(pchar(msg),pchar(application.title),mb_ok+mb_iconinformation);
end;

function GetGUID:string;
var
id:tguid;
begin
if CoCreateGuid(id)=s_ok then
result:=guidtostring(id);
end;

function SelectDirectory(handle:hwnd;const Caption: string;
const Root: WideString;out Directory: string): Boolean;
var
lpbi:_browseinfo;
buf:array [0..MAX_PATH] of char;
id:ishellfolder;
eaten,att:cardinal;
rt:pitemidlist;
initdir:pwidechar;
begin
result:=false;
lpbi.hwndOwner:=handle;
lpbi.lpfn:=nil;
lpbi.lpszTitle:=pchar(caption);
lpbi.ulFlags:=BIF_RETURNONLYFSDIRS+64;
SHGetDesktopFolder(id);
initdir:=pwchar(root);
id.ParseDisplayName(0,nil,initdir,eaten,rt,att);
lpbi.pidlRoot:=rt;
getmem(lpbi.pszDisplayName,MAX_PATH);
try
result:=shgetpathfromidlist(shbrowseforfolder(lpbi),buf);
except
freemem(lpbi.pszDisplayName);
end;
if result then
directory:=buf;
end;

end.

 
你看到tools.hpp存在吗?
要是不存在,先切换到tools.pas,然后按 alt+F9 单独编译tools.pas一次,就有tools.hpp了
 
pipi 正确,另外bcb6的补丁一定加上。
 
来迟啦。楼上二位说得对。
 
我曾经做过一个类似的
开始时的确编译不过
分析代码时发现BCB生成的代码有误
经过修改后就可以了
 
我用Alt+F编译了一次
有了hpp文件,但是这个tools.hpp里有几个函数是错的,CB就编译不通过
我知道这个tools.pas有几个函数不能用,关系到几个dll的问题,我只用里面几个好用的
Delphi里我可以这样用,但是CB里怎么一定要都没有错误才让你编译通过
我现在怎么办?????
 
把不能用的剔除就可以了。bcb有错误是不允许的。delphi可以吗?这可不知道。
 
多人接受答案了。
 

Similar threads

S
回复
0
查看
700
SUNSTONE的Delphi笔记
S
S
回复
0
查看
589
SUNSTONE的Delphi笔记
S
S
回复
0
查看
694
SUNSTONE的Delphi笔记
S
S
回复
0
查看
686
SUNSTONE的Delphi笔记
S
I
回复
0
查看
692
import
I
后退
顶部