名稱 類型 說明
abort 函數 引起放棄的意外處理
abs 函數 絕對值函數
addexitproc 函數 將一過程添加到運行時庫的結束過程表中
addr 函數 返回指定對象的地址
adjustlinebreaks 函數 將給定字符串的行分隔符調整爲cr/lf序列
align 屬性 使控件位於窗口某部分
alignment 屬性 控件標籤的文字位置
allocmem 函數 在堆棧上分配給定大小的塊
allowgrayed 屬性 允許一個灰度選擇
ansicomparestr 函數 比較字符串（區分大小寫）
ansicomparetext 函數 比較字符串（不區分大小寫）
ansilowercase 函數 將字符轉換爲小寫
ansiuppercase 函數 將字符轉換爲大寫
append 函數 以附加的方式打開已有的文件
arctan 函數 餘切函數
assignfile 函數 給文件變量賦一外部文件名
assigned 函數 測試函數或過程變量是否爲空
autosize 屬性 自動控制標籤的大小
backgrounddi2001.jpg 屬性 背景色
beginthread 函數 以適當的方式建立用於內存管理的線程
bevelinner 屬性 控件方框的內框方式
bevelouter 屬性 控件方框的外框方式
bevelwidth 屬性 控件方框的外框寬度
blockread 函數 讀一個或多個記錄到變量中
blockwrite 函數 從變量中寫一個或多個記錄
borderstyle 屬性 邊界類型
borderwidth 屬性 邊界寬度
break 命令 終止for、while、repeat循環語句
brush 屬性 畫刷
caption 屬性 標籤文字的內容
changefileext 函數 改變文件的後綴
chdir 函數 改變當前目錄
checked 屬性 確定複選框選中狀態
chr 函數 返回指定序數的字符
closefile 命令 關閉打開的文件
color 屬性 標籤的顏色
columns 屬性 顯示的列數
comparestr 函數 比較字符串（區分大小寫）
concat 函數 合併字符串
continue 命令 繼續for、while、repeat的下一個循環
copy 函數 返回一字符串的子串
cos 函數 餘弦函數
ctl3d 屬性 是否具有3d效果
cursor 屬性 鼠標指針移入後的形狀
date 函數 返回當前的日期
datetimetofiledate 函數 將delphi的日期格式轉換爲dos的日期格式
datetimetostr 函數 將日期時間格式轉換爲字符串
datetimetostring 函數 將日期時間格式轉換爲字符串
datetostr 函數 將日期格式轉換爲字符串
dayofweek 函數 返回星期的數值
dec 函數 遞減變量值
decodedate 函數 將日期格式分解爲年月日
decodetime 函數 將時間格式分解爲時、分、秒、毫秒
delete 函數 從字符串中刪除子串
deletefile 命令 刪除文件
diskfree 函數 返回剩餘磁盤空間的大小
disksize 函數 返回指定磁盤的容量
dispose 函數 釋放動態變量所佔的空間
disposestr 函數 釋放字符串在堆棧中的內存空間
ditherbackgrounddi2001.jpg?使背景色的色彩加重或減少50%
dragcursor 屬性 當鼠標按下時光標的形狀
dragmode 屬性 按動的作用方式
dropdowncount 屬性 容許的顯示數據項的數目
editmask 屬性 編輯模式
enabled 屬性 是否使標籤呈現打開狀態
encodedate 函數 將年月日合成爲日期格式
encodetime 函數 將時、分、秒、毫秒合成爲時間格式
endmargin 屬性 末尾邊緣
eof 函數 對有類型或無類型文件測試是否到文件尾
eoln 函數 返回文本文件的行結束狀態
erase 命令 刪除外部文件
exceptaddr 函數 返回引起當前意外的地址
exclude 函數 從集合中刪除一些元素
exceptobject 函數 返回當前意外的索引
exit 命令 立即從當前的語句塊中退出
exp 函數 指數函數
expandfilename 函數 返回包含絕對路徑的字符串
extendedselect 屬性 是否允許存在選擇模式，true時，multiselect纔有意義
extractfiledir 函數 返回驅動器和路徑
extractfileext 函數 返回文件的後綴
extractfilename 函數 返回文件名
extractfilepath 函數 返回指定文件的路徑
fileage 函數 返回文件已存在的時間
fileclose 命令 關閉指定的文件
filecreate 命令 用指定的文件名建立新文件
filedatetodatetime 函數 將dos的日期格式轉換爲delphi的日期格式
fileexists 函數 檢查文件是否存在
filegatattr 函數 返回文件的屬性
filegetdate 函數 返回文件的dos日期時間標記
fileopen 命令 用指定的存取模式打開指定的文件
filepos 函數 返回文件的當前指針位置
fileread 命令 從指定的文件讀取
filesearch 命令 在目錄中搜索指定的文件
fileseek 函數 改變文件的指針
filesetattr 函數 設置文件屬性
filesetdate 函數 設置文件的dos日期時間標記
filesize 函數 返回當前文件的大小
filewrite 函數 對指定的文件做寫操作
fillchar 函數 用指定的值填充連續字節的數
findclose 命令 終止findfirst/findnext序列
findfirst 命令 對指定的文件名及屬性搜索目錄
findnext 命令 返回與文件名及屬性匹配的下一入口
floattodecimal 函數 將浮點數轉換爲十進制數
floattostrf 函數 將浮點數轉換爲字符串
floattostr 函數 將浮點數轉換爲字符串
floattotext 函數 將給定的浮點數轉換爲十進制數
floattotextfmt 函數 將給定的浮點數轉換爲十進制數
flush 函數 將緩衝區的內容刷新到輸出的文本文件中
fmtloadstr 函數 從程序的資源字符串表中裝載字符串
fmtstr 函數 格式化一系列的參數，其結果以參數result返回
font 屬性 設置字體
format 函數 格式化一系列的參數並返回pascal字符串
formatbuf 函數 格式化一系列的參數
formatdatetime 函數 用指定的格式來格式化日期和時間
formatfloat 函數 指定浮點數格式
frac 函數 返回參數的小數部分
freemem 函數 按給定大小釋放動態變量所佔的空間
getdir 返回指定驅動器的當前目錄
getheapstatus 返回內存管理器的當前狀態
getmem 建立一指定大小的動態變量，並將指針指向該處
getmemorymanager 返回內存管理器的入口點
glyph 函數 按鈕上的圖象
halt 停止程序的執行並返回到操作系統
hi 返回參數的高地址位
high 返回參數的上限值
hint 屬性 提示信息
int 返回參數的整數部分
include 添加元素到集合中
insert 在字符串中插入子串
inttohex 將整型數轉換爲十六進制數
inttostr 將整型數轉換爲字符串
ioresult 返回最新的i/o操作完成狀態
isvalidident 測試字符串是否爲有效的標識符
items 屬性 默認顯示的節點
kind 屬性 擺放樣式
largechange 屬性 最大改變值
layout 屬性 圖象佈局
length 函數 返回字符串的動態長度
lines 屬性 缺省顯示內容
ln 函數 自然對數函數
lo 函數 返回參數的低地址位
loadstr 函數 從應用程序的可執行文件中裝載字符資源
lowercase 函數 將給定的字符串變爲小寫
low 函數 返回參數的下限值
max 屬性 最大值
maxlength 屬性 最大長度
min 屬性 最小值
mkdir 命令 建立一子目錄
move 函數 從源到目標複製字節
multiselect 屬性 允許同時選擇幾個數據項
name 屬性 控件的名字
new 函數 建立新的動態變量並設置一指針變量指向他
newstr 函數 在堆棧上分配新的字符串
now 函數 返回當前的日期和時間
odd 測試參數是否爲奇數
onactivate 事件 焦點移到窗體上時觸發
onclick 事件 單擊窗體空白區域觸發
ondblclick 事件 雙擊窗體空白區域觸發
onclosequery 事件 使用者試圖關閉窗體觸發
onclose 事件 窗體關閉後才觸發
oncreate 事件 窗體第一次創建時觸發
ondeactivate 事件 用戶切換到另一應用程序觸發
ondragdrop 事件 鼠標拖放操作結束時觸發
ondragover 事件 有其他控件從他上面移過觸發
onmousedown 事件 按下鼠標鍵時觸發
onmouseup 事件 釋放鼠標鍵時觸發
onmousemove 事件 移動鼠標時觸發
onhide 事件 隱藏窗體時觸發
onkeydown 事件 按下鍵盤某鍵時觸發
onkeypress 事件 按下鍵盤上的單個字符鍵時觸發
onkeyup 事件 釋放鍵盤上的某鍵時觸發
onpaint 事件 窗體上有新部分暴露出來觸發
onresize 事件 重新調整窗體大小觸發
onshow 事件 在窗體實際顯示之前瞬間觸發
ord 返回序數類的序數
outlinestyle 屬性 類型
outofmemoryerror 引起outofmemory意外
pageindex 屬性 頁索引
pages 屬性 頁
paramcount 函數 返回在命令行上傳遞給程序的參數數量
paramstr 函數 返回指定的命令行參數
pen 屬性 畫刷設置
pi 函數 返回圓周率pi
picture 屬性 顯示圖象
pictureclosed 屬性 設置closed位圖
pictureleaf 屬性 設置leaf位圖
pictureminus 屬性 設置minus位圖
pictureopen 屬性 設置open位圖
pictureplus 屬性 設置plus位圖
pos 函數 在字符串中搜索子串
pred 函數 返回先前的參數
random 函數 返回一隨機函數
randomize 函數 用一隨機數初始化內置的隨機數生成器
read 函數 對有格式的文件，讀一文件組件到變量中；
對文本文件，讀一個或多個值到一個或多個變量中
readln 函數 執行read過程，然後跳到文件下一行
readonly 屬性 只讀屬性
reallocmem 函數 分配一動態變量
rename 函數 重命名外部文件
renamefile 函數 對文件重命名
reset 函數 打開已有的文件
rewrite 函數 建立並打開一新的文件
rmdir 函數 刪除空的子目錄
round 函數 將實數值舍入爲整型值
runerror 函數 停止程序的執行
scrollbars 屬性 滾動條狀態
seek 函數 將文件的當前指針移動到指定的組件上
seekeof 函數 返回文件的文件結束狀態
seekeoln 函數 返回文件的行結束狀態
selectedcolor 屬性 選中顏色
setmemorymanager 函數 設置內存管理器的入口點
settextbuf 函數 給文本文件指定i/o緩衝區
shape 屬性 顯示的形狀
showexception 函數 顯示意外消息與地址
sin 函數 正弦函數
sizeof 函數 返回參數所佔的字節數
smallchange 屬性 最小改變值
sorted 屬性 是否允許排序
sqr 函數 平方函數
sqrt 函數 平方根函數
startmargin 屬性 開始邊緣
state 屬性 控件當前狀態
str 函數 將數值轉換爲字符串
stralloc 函數 給以null結束的字符串分配最大長度-1的緩衝區
strbufsize 函數 返回存儲在由stralloc分配的字符緩衝區的最大字符數
strcat 函數 將一字符串附加到另一字符串尾並返回合併的字符串
strcomp 函數 比較兩個字符串
strcopy 函數 將一個字符串複製到另一個字符串中
strdispose 函數 釋放堆棧上的字符串
strecopy 函數 將一字符串複製到另一個字符串並返回結果字符串尾部的指針
strend 函數 返回指向字符串尾部的指針
stretch 屬性 自動適應控件的大小
strfmt 函數 格式化一系列的參數
stricomp 函數 比較兩個字符串（不區分大小寫）
stringtowidechar 函數 將ansi字符串轉換爲unicode字符串
strlcat 函數 將一字符串中的字符附加到另一字符串尾並返回合併的字符串
strlcomp 函數 以最大長度比較兩個字符串
strlcopy 函數 將一個字符串中的字符複製到另一個字符串中
strlen 函數 返回字符串中的字符數
strlfmt 函數 格式化一系列的參數，其結果中包含有指向目標緩衝區的指針
strlicomp 函數 以最大長度比較兩個字符串（不區分大小寫）
strlower 函數 將字符串中的字符轉換爲小寫
strmove 函數 將一個字符串中的字符複製到另一個字符串中
strnew 函數 在堆棧上分配一個字符串
strpas 函數 將以null結束的字符串轉換爲pascal類的字符串
strpcopy 函數 將pascal類的字符串複製爲以null結束的字符串
strplcopy 函數 從pascal類的最大長度字符串複製爲以null結束的字符串
strpos 函數 返回一個字符串在另一個字符串中首次出現指針
strrscan 函數 返回字符串中最後出現字符的指針
strscan 函數 返回字符串中出現首字符的指針
strtodate 函數 將字符串轉換爲日期格式
strtodatetime 函數 將字符串轉換爲日期/時間格式
strtofloat 函數 將給定的字符串轉換爲浮點數
strtoint 函數 將字符串轉換爲整型
strtointdef 函數 將字符串轉換爲整型或默認值
strtotime 函數 將字符串轉換爲時間格式
strupper 函數 將字符串中的字符轉換爲大寫
style 屬性 類型選擇
suce 函數 返回後繼的參數
swap 函數 交換參數的高低地址位
tabs 屬性 標記每一項的內容
tabindex 屬性 標記索引
text 屬性 顯示的文本
texttofloat 函數 將字符串（以null結束的格式）轉換爲浮點數
time 函數 返回當前的時間
timetostr 函數 將時間格式轉換爲字符串
trim 函數 從給定的字符串中刪除前導和尾部的空格及控制字符
trimleft 函數 從給定的字符串中刪除首部的空格及控制字符
trimright 函數 從給定的字符串中刪除尾部的空格及控制字符
trunc 函數 將實型值截取爲整型值
truncate 函數 截去當前文件位置後的內容
unselectedcolor 屬性 未選中顏色
upcase 將字符轉換爲大寫
uppercase 將給定的字符串變爲大寫
val 函數 將字符串轉換爲整型值
vararraycreate 函數 以給定的界限和維數建立變體數組
vararraydimcount 函數 返回給定變體的維數
vararrayhighbound 函數 返回給定變體數組維數的上界
vararraylock 函數 鎖定給定的變體數組
vararraylowbound 函數 返回給定變體數組維數的下界
vararrayof 函數 返回指定變體的數組元素
vararrayredim 函數 通過改變上限來調整變體的大小
vararrayunlock 函數 解鎖指定的變體數組
varastype 函數 將變體轉換爲指定的類型
varcase 函數 將變體轉換爲指定的類型並保存他
varclear 函數 清除指定的變體
varcopy 函數 將指定的變體複製爲指定的變體
varformdatetime 函數 返回包含日期時間的變體
varisarray 函數 測試變體是否爲數組
varisempty 函數 測試變體是否爲unassigned
varisnull 函數 測試變體是否爲null
vartodatetime 函數 將給定的變體轉換爲日期時間
vartype 函數 將變體轉換爲指定的類型並保存他
visible 屬性 控件的可見性
wantreturns 屬性 爲true時，按回車鍵產生一個回車符；
爲false時，按下ctrl+enter才產生回車符
write 命令 對有格式的文件，寫一變量到文件組件中；
對文本文件，寫一個或多個值到文件中
writeln 命令 執行write過程，然後輸出一行結束標誌
widecharlentostring 函數 將ansi字符串轉換爲unicode字符串
widecharlentostrwar 函數 將unicode字符串轉換爲ansi字符串變量
widechartostring 函數 將unicode字符串轉換爲ansi字符串
widechartostrvar 函數 將unicode字符串轉換爲ansi字符串變量
來自: daocaoren0824, 時間: 2005-10-21 11:48:42, ID: 3240062
再給你一份 程序員實用函數
{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}
{▎ ▎}
{▎ 大家都是程序員 沒有必要重複一些無聊的事情 我的這些函數能給大家帶來方便 ▎}
{▎ 如果覺得還一般 請關注 WWW.cdsunco.com/www.ccemove.com QQ:35013354 ▎}
{▎ 系統公用函數及過程 ▎}
{▎ ▎}
{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}
{▎ 軟件名稱： 開發包基礎庫 ▎}
{▎ 單元名稱： 公共運行時間庫單元 ▎}
{▎ 單元版本： V1.0 ▎}
{▎ 備 注： 該單元定義了組件包的基礎類庫 ▎}
{▎ 開發平臺： PWin98SE + Delphi 6.0 ▎}
{▎ 兼容測試： PWin9X/2000/XP + Delphi 6.0 ▎}
{▎ 本 地 化： 該單元中的字符串均符合本地化處理方式 ▎}
{▎ 更新記錄： 2002.07.03 V2.0 ▎}
{▎ 整理單元，重設版本號 ▎}
{▎ 2002.03.17 V0.02 ▎}
{▎ 新增部分函數，並部分修改 ▎}
{▎ 2002.01.30 V0.01 ▎}
{▎ 創建單元（整理而來） ▎}
{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}
{▎ ①: 擴展的字符串操作函數 ▎}
{▎ ②: 擴展的日期時間操作函數 ▎}
{▎ ③: 擴展的位操作函數 ▎}
{▎ ④: 擴展的文件及目錄操作函數 ▎}
{▎ ⑤: 擴展的對話框函數 ▎}
{▎ ⑥: 系統功能函數 ▎}
{▎ ⑦: 硬件功能函數 ▎}
{▎ ⑧: 網絡功能函數 ▎}
{▎ ⑨: 漢字拼音函數及過程 ▎}
{▎ ⑩: 數據庫功能函數 ▎}
{▎ ⑾: 進制功能函數 ▎}
{▎ ⑿: 其它功能函數 ▎}
{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}
unit Communal;
{* |<PRE>
|</PRE>}
interface
{$I CnPack.inc}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
FileCtrl, ShellAPI, CommDlg, MMSystem, WinSock, IniFiles, DBTables, BDE,
StdCtrls, ComObj, ADODB, Imm, DbCtrls, Db, Registry;
const
// 公共信息
{$IFDEF GB2312}
SCnInformation = '提示';
SCnWarning = '警告';
SCnError = '錯誤';
{$ELSE}
SCnInformation = 'Information';
SCnWarning = 'Warning';
SCnError = 'Error';
{$ENDIF}
C1=52845; //字符串加密算法的公匙
C2=22719; //字符串加密算法的公匙
resourcestring
{$IFDEF GB2312}
SUnknowError = '未知錯誤';
SErrorCode = '錯誤代碼：';
{$ELSE}
SUnknowError = 'Unknow error';
SErrorCode = 'Error code:';
{$ENDIF}
type
EDBUpdateErr = class(Exception);//修改表結構時觸發的錯誤句柄
//▎============================================================▎//
//▎================① 擴展的字符串操作函數 ===================▎//
//▎============================================================▎//
//從文件中返回Ado連接字串。
function GetConnectionString(DataBaseName:string):string;
//返回服務器的機器名稱.
function GetRemoteServerName:string;
function InStr(const sShort: string; const sLong: string): Boolean; {測試通過}
{* 判斷s1是否包含在s2中}
function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string; {測試通過}
{* 擴展整數轉字符串函數 Example: IntToStrEx(1,5,'0'); 返回："00001"}
function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string; {測試通過}
{* 帶分隔符的整數－字符轉換}
function ByteToBin(Value: Byte): string; {測試通過}
{* 字節轉二進制串}
function StrRight(Str: string; Len: Integer): string; {測試通過}
{* 返回字符串右邊的字符 Examples: StrRight('ABCEDFG',3); 返回:'DFG' }
function StrLeft(Str: string; Len: Integer): string; {測試通過}
{* 返回字符串左邊的字符}
function Spc(Len: Integer): string; {測試通過}
{* 返回空格串}
function Replace(Str,s1,s2:string;CaseSensitive:Boolean):string; {測試通過}
{* 返回將指定字符s1用字符串s2替換後的字符串，可支持大小寫敏感由CaseSensitive操作}
{example: replace('We know what we want','we','I',false) = 'I Know what I want'}
function Replicate(pcChar:Char; piCount:integer):string;
{在一個字符串中查找某個字符串的位置}
function StrNum(ShortStr:string;LongString:string):Integer; {測試通過}
{* 返回某個字符串中某個字符串中出現的次數}
function FindStr(ShortStr:String;LongStrIng:String):Integer; {測試通過}
{* 返回某個字符串中查找某個字符串的位置}
function SubStr(psInput:String; BeginPlace,CutLeng:Integer):String; {測試通過}
{* 返回從位置BeginPlace開始切取長度爲CatLeng字符串}
function LeftStr(psInput:String; CutLeng:Integer):String; {測試通過}
{* 返回從左邊第一爲開始切取 CutLeng長度的字符串}
function RightStr(psInput:String; CutLeng:Integer):String; {測試通過}
{* 返回從右邊第一爲開始切取 CutLeng長度的字符串}
function PadLStr(psInput:String; piWidth:Integer; pcPadWith:Char):String; {測試通過}
{* 返回從psInput字符串左邊開始用pcPadWith填充後總長度爲PiWidth的字符串}
function PadRStr(psInput:String; piWidth:Integer; pcPadWith:Char):String; {測試通過}
{* 返回從psInput字符串右邊開始用pcPadWith填充後總長度爲PiWidth的字符串}
function PadCStr(psInput:String; piWidth:Integer; pcPadWith:Char):String; {測試通過}
{* 返回從psInput字符串兩邊開始用pcPadWith填充後總長度爲PiWidth的字符串}
function ChrTran(psInput:String; pcSearch:Char; pcTranWith:Char):String; {測試通過}
{* 返回替換後字符串[替換單個字符] Examples: ChrTran('abCdEgdlkh','d','#')； 返回'abC#Eg#lkh'}
function StrTran(psInput:String; psSearch:String; psTranWith:String):String; {測試通過}
{* 返回替換後字符串[替換字符串] Examples: StrTran('aruyfbn','ruy','=====');； 返回'a=====fbn'}
function Stuff(psInput:String; piBeginPlace,piCount:Integer; psStuffWith:String):String;
{ *返回替換後字符串[替換字符串] Examples: Stuff('ABCDEFGHI',3,4,'12345')；返回'AB12345GHI'}
procedure SwapStr(var s1, s2: string); {測試通過}
{* 交換字串}
function LinesToStr(const Lines: string): string; {測試通過}
{* 多行文本轉單行（換行符轉'/n'）}
function StrToLines(const Str: string): string; {測試通過}
{* 單行文本轉多行（'/n'轉換行符）}
function Encrypt(const S: String; Key: Word): String;
{* 字符串加密函數}
function Decrypt(const S: String; Key: Word): String;
{* 字符串解密函數}
function varIIF(aTest: Boolean; TrueValue, FalseValue: Variant): Variant;
function varToStr(const V: Variant): string;
{* VarIIF及VartoStr爲變體函數}
function IsDigital(Value: string): boolean;
{功能說明：判斷string是否全是數字}
function RandomStr(aLength : Longint) : String;
{隨機字符串函數}
//▎============================================================▎//
//▎================② 擴展的日期時間操作函數 =================▎//
//▎============================================================▎//
function GetYear(Date: TDate): Integer; {測試通過}
{* 取日期年份分量}
function GetMonth(Date: TDate): Integer; {測試通過}
{* 取日期月份分量}
function GetDay(Date: TDate): Integer; {測試通過}
{* 取日期天數分量}
function GetHour(Time: TTime): Integer; {測試通過}
{* 取時間小時分量}
function GetMinute(Time: TTime): Integer; {測試通過}
{* 取時間分鐘分量}
function GetSecond(Time: TTime): Integer; {測試通過}
{* 取時間秒分量}
function GetMSecond(Time: TTime): Integer; {測試通過}
{* 取時間毫秒分量}
function GetMonthLastDay(Cs_Year,Cs_Month:string):string;
{ *傳入年、月，得到該月份最後一天}
function IsLeapYear( nYear: Integer ): Boolean;
{*/判斷某年是否爲閏年}
function MaxDateTime(const Values: array of TDateTime): TDateTime;
{//兩個日期取較大的日期}
function MinDateTime(const Values: array of TDateTime): TDateTime;
{//兩個日期取較小的日期}
function dateBeginOfMonth(D: TDateTime): TDateTime;
{//得到本月的第一天}
function DateEndOfMonth(D: TDateTime): TDateTime;
{//得到本月的最後一天}
function DateEndOfYear(D: TDateTime): TDateTime;
{//得到本年的最後一天}
function DaysBetween(Date1, Date2: TDateTime): integer;
{//得到兩個日期相隔的天數}
//▎============================================================▎//
//▎===================③ 擴展的位操作函數 ====================▎//
//▎============================================================▎//
type
TByteBit = 0..7;
{* Byte類型位數範圍}
TWordBit = 0..15;
{* Word類型位數範圍}
TDWordBit = 0..31;
{* DWord類型位數範圍}
procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean); overload;
{* 設置二進制位}
procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean); overload;
{* 設置二進制位}
procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean); overload;
{* 設置二進制位}
function GetBit(Value: Byte; Bit: TByteBit): Boolean; overload;
{* 取二進制位}
function GetBit(Value: WORD; Bit: TWordBit): Boolean; overload;
{* 取二進制位}
function GetBit(Value: DWORD; Bit: TDWordBit): Boolean; overload;
{* 取二進制位}
//▎============================================================▎//
//▎=================④擴展的文件及目錄操作函數=================▎//
//▎============================================================▎//
function MoveFile(const sName, dName: string): Boolean; {測試通過}
{* 移動文件、目錄，參數爲源、目標名}
procedure FileProperties(const FName: string); {測試通過}
{* 打開文件屬性窗口}
function OpenDialog(var FileName: string; Title: string; Filter: string;
Ext: string): Boolean;
{* 打開文件框}
function FormatPath(APath: string; Width: Integer): string; {測試通過}
{* 縮短顯示不下的長路徑名}
function GetRelativePath(Source, Dest: string): string; {測試通過}
{* 取兩個目錄的相對路徑,注意串尾不能是'/'字符！}
procedure RunFile(const FName: string; Handle: THandle = 0;
const Param: string = ''); {測試通過}
{* 運行一個文件}
function WinExecAndWait32(FileName: string; Visibility: Integer = SW_NORMAL):
Integer; {測試通過}
{* 運行一個文件並等待其結束}
function AppPath: string; {測試通過}
{* 應用程序路徑}
function GetWindowsDir: string; {測試通過}
{* 取Windows系統目錄}
function GetWinTempDir: string; {測試通過}
{* 取臨時文件目錄}
function AddDirSuffix(Dir: string): string; {測試通過}
{* 目錄尾加'/'修正}
function MakePath(Dir: string): string; {測試通過}
{* 目錄尾加'/'修正}
function IsFileInUse(FName: string): Boolean; {測試通過}
{* 判斷文件是否正在使用}
function GetFileSize(FileName: string): Integer; {測試通過}
{* 取文件長度}
function SetFileDate(FileName: string; CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean; {測試通過}
{* 設置文件時間 Example: FileSetDate('c:/Test/Test1.exe',753160662); }
function GetFileDate(FileName: string; var CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean; {測試通過}
{* 取文件時間}
function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime; {測試通過}
{* 文件時間轉本地時間}
function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime; {測試通過}
{* 本地時間轉文件時間}
function GetFileIcon(FileName: string; var Icon: TIcon): Boolean; {測試通過}
{* 取得與文件相關的圖標，成功則返回True}
function CreateBakFile(FileName, Ext: string): Boolean; {測試通過}
{* 創建備份文件}
function Deltree(Dir: string): Boolean; {測試通過}
{* 刪除整個目錄}
function GetDirFiles(Dir: string): Integer; {測試通過}
{* 取文件夾文件數}
type
TFindCallBack = procedure(const FileName: string; const Info: TSearchRec;
var Abort: Boolean);
{* 查找指定目錄下文件的回調函數}
procedure FindFile(const Path: string; const FileName: string = '*.*';
Proc: TFindCallBack = nil; bSub: Boolean = True; const bMsg: Boolean = True);
{* 查找指定目錄下文件}
procedure FindFileList(Path,Filter:string;FileList:TStrings;ContainSubDir:Boolean);
{ 功能說明：查找一個路徑下的所有文件。
參數： path:路徑,filter:文件擴展名過濾,FileList:文件列表, ContainSubDir:是否包含子目錄}
function Txtline(const txt: string): integer;
{* 返回一文本文件的行數}
function Html2Txt(htmlfilename: string): string;
{* Html文件轉化成文本文件}
function OpenWith(const FileName: string): Integer; {測試通過}
{* 文件打開方式}
//▎============================================================▎//
//▎====================⑤擴展的對話框函數======================▎//
//▎============================================================▎//
procedure InfoDlg(Mess: string; Caption: string = SCnInformation; Flags: Integer
= MB_OK + MB_ICONINFORMATION); {測試通過}
{* 顯示提示窗口}
function InfoOk(Mess: string; Caption: string = SCnInformation): Boolean; {測試通過}
{* 顯示提示確認窗口}
procedure ErrorDlg(Mess: string; Caption: string = SCnError); {測試通過}
{* 顯示錯誤窗口}
procedure WarningDlg(Mess: string; Caption: string = SCnWarning); {測試通過}
{* 顯示警告窗口}
function QueryDlg(Mess: string; Caption: string = SCnInformation): Boolean; {測試通過}
{* 顯示查詢是否窗口}
procedure SetWindowAnimate(Sender : TForm; IsSetAni : bool);
//▎============================================================▎//
//▎=====================⑥系統功能函數=========================▎//
//▎============================================================▎//
procedure MoveMouseIntoControl(AWinControl: TControl); {測試通過}
{* 移動鼠標到控件}
function DynamicResolution(x, y: WORD): Boolean; {測試通過}
{* 動態設置分辨率}
procedure StayOnTop(Handle: HWND; OnTop: Boolean); {測試通過}
{* 窗口最上方顯示}
procedure SetHidden(Hide: Boolean); {測試通過}
{* 設置程序是否出現在任務欄}
procedure SetTaskBarVisible(Visible: Boolean); {測試通過}
{* 設置任務欄是否可見}
procedure SetDesktopVisible(Visible: Boolean); {測試通過}
{* 設置桌面是否可見}
procedure BeginWait; {測試通過}
{* 顯示等待光標}
procedure EndWait; {測試通過}
{* 結束等待光標}
function CheckWindows9598NT: string; {測試通過}
{* 檢測是否Win95/98/NT平臺}
function GetOSInfo : String; {測試通過}
{* 取得當前操作平臺是 Windows 95/98 還是NT}
function GetCurrentUserName : string;
{*獲取當前Windows登錄名的用戶}
function GetRegistryOrg_User(UserKeyType:string):string;
{*獲取當前註冊的單位及用戶名稱}
function GetSysVersion:string;
{*//獲取操作系統版本號}
function WinBootMode:string;
{//Windows啓動模式}
type
PShutType = (UPowerOff, UShutdown, UReboot, ULogOff, USuspend, UHibernate);
procedure WinShutDown(ShutWinType:PShutType; PForce:Boolean);
{//Windows ShutDown等}
//▎============================================================▎//
//▎=====================⑦硬件功能函數=========================▎//
//▎============================================================▎//
function GetClientGUID:string;
{ 功能描述：在本機上得到一個GUID.去掉兩端的大括號和中間的橫線
返回值：去掉兩端的大括號和中間的橫線的一個GUID
適用範圍：windows
}
function SoundCardExist: Boolean; {測試通過}
{* 聲卡是否存在}
function GetDiskSerial(DiskChar: Char): string;
{* 獲取磁盤序列號}
function DiskReady(Root: string) : Boolean;
{*檢查磁盤準備是否就緒}
procedure WritePortB( wPort : Word; bValue : Byte );
{* 寫串口}
function ReadPortB( wPort : Word ) : Byte;
{*讀串口}
function CPUSpeed: Double;
{* 獲知當前機器CPU的速率（MHz）}
type
TCPUID = array[1..4] of Longint;
function GetCPUID : TCPUID; assembler; register;
{*獲取CPU的標識ID號*}
function GetMemoryTotalPhys : Dword;
{*獲取計算機的物理內存}
type
TDriveState = (DSNODISK, DSUNFORMATTEDDISK, DSEMPTYDISK, DSDISK_WITHFILES);
function DriveState (driveletter: Char) : TDriveState;
{* 檢查驅動器A中磁盤是否有效}
//▎============================================================▎//
//▎=====================⑧網絡功能函數=========================▎//
//▎============================================================▎//
function GetComputerName:string;
{* 獲取網絡計算機名稱}
function GetHostIP:string;
{* 獲取計算機的IP地址}
function NetUserChangePassword(Domain:PWideChar; UserName:PWideChar; OldPassword:PWideChar; NewPassword:PWideChar): LongInt; stdcall; external 'netapi32.dll' name 'NetUserChangePassword';
{* // 運行平臺：Windows NT/2000/XP
{* // Windows 95/98/Me平臺：可以用該函數修改用戶的Windows登錄密碼}
//▎============================================================▎//
//▎=====================⑨漢字拼音功能函數=====================▎//
//▎============================================================▎//
function GetHzPy(const AHzStr: string): string; {測試通過}
{* 取漢字的拼音}
function HowManyChineseChar(Const s:String):Integer;
{* 判斷一個字符串中有多少各漢字}
//▎============================================================▎//
//▎===================⑩數據庫功能函數及過程===================▎//
//▎============================================================▎//
{function PackDbDbf(Var StatusMsg: String): Boolean;}
{* 物理刪除數據庫(Db，Dbf)中的數據[着了刪除標記的記錄]}
procedure RepairDb(DbName: string);
{* 修復Access表}
function CreateODBCCfgInRegistry(ODBCSourceName:WideString;ServerName, DataBaseDescription:String):boolean;
{* 通過註冊表創建ODBC配置[創建在系統DSN頁下]}
function ADOConnectSysBase(Const Adocon:TadoConnection):boolean;
{* 用Ado連接SysBase數據庫函數}
function ADOConnectLocalDB(Const Adocon:TadoConnection;Const Dbname,DbServerName:string;ValidateMode:Integer):boolean;
{* 用Ado連接數據庫函數}
function ADOODBCConnectLocalDB(Const Adocon:TadoConnection;Const Dbname:string;ValidateMode:Integer):boolean;
{* 用Ado與ODBC共同連接數據庫函數}
function CreatTable(LpDataBaseName,LpTableName,LpSentence:string):Boolean;
{* //建立新表}
function AddField(LpFieldName:string; LpDataType: TFieldType; LpSize: Word):string;
{*//在表中添加字段}
function KillField(LpFieldName:string):String;
{* //在表中刪除字段}
function AlterTableExec(LpDataBaseName,LpSentence:string):Boolean;
{* //修改表結構}
function GetSQLSentence(LpTableName,LpSQLsentence:string): string;
{* /修改、添加、刪除表結構時的SQL句體}
//▎============================================================▎//
//▎======================⑾進制函數及過程======================▎//
//▎============================================================▎//
function StrToHex(AStr: string): string;
{* 字符轉化成十六進制}
function HexToStr(AStr: string): string;
{* 十六進制轉化成字符}
function TransChar(AChar: Char): Integer;
//▎============================================================▎//
//▎=====================⑿其它函數及過程=======================▎//
//▎============================================================▎//
function TrimInt(Value, Min, Max: Integer): Integer; overload; {測試通過}
{* 輸出限制在Min..Max之間}
function IntToByte(Value: Integer): Byte; overload; {測試通過}
{* 輸出限制在0..255之間}
function InBound(Value: Integer; Min, Max: Integer): Boolean; {測試通過}
{* 判斷整數Value是否在Min和Max之間}
procedure CnSwap(var A, B: Byte); overload;
{* 交換兩個數}
procedure CnSwap(var A, B: Integer); overload;
{* 交換兩個數}
procedure CnSwap(var A, B: Single); overload;
{* 交換兩個數}
procedure CnSwap(var A, B: Double); overload;
{* 交換兩個數}
function RectEqu(Rect1, Rect2: TRect): Boolean;
{* 比較兩個Rect是否相等}
procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);
{* 分解一個TRect爲左上角座標x, y和寬度Width、高度Height}
function EnSize(cx, cy: Integer): TSize;
{* 返回一個TSize類型}
function RectWidth(Rect: TRect): Integer;
{* 計算TRect的寬度}
function RectHeight(Rect: TRect): Integer;
{* 計算TRect的高度}
procedure Delay(const uDelay: DWORD); {測試通過}
{* 延時}
procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1); {Win9X下測試通過}
{* 只能在Win9X下讓喇叭發聲}
procedure ShowLastError; {測試通過}
{* 顯示Win32 Api運行結果信息}
function writeFontStyle(FS: TFontStyles; inifile: string; write: boolean):string;
{* 將字體Font.Style寫入INI文件}
function readFontStyle(inifile: string): TFontStyles;
{* 從INI文件中讀取字體Font.Style文件}
//function ReadCursorPos(SourceMemo: TMemo): TPoint;
function ReadCursorPos(SourceMemo: TMemo): string;
{* 取得TMemo 控件當前光標的行和列信息到Tpoint中}
function CanUndo(AMemo: TMemo): Boolean;
{* 檢查Tmemo控件能否Undo}
procedure Undo(Amemo: Tmemo);
{*實現Undo功能}
procedure AutoListDisplay(ACombox:TComboBox);
{* 實現ComBoBox自動下拉}
function UpperMoney(small:real):string;
{* 小寫金額轉換爲大寫 }
function Myrandom(Num: Integer): integer;
{*利用系統時間產生隨機數)}
procedure OpenIME(ImeName: string);
{*打開輸入法}
procedure CloseIME;
{*關閉輸入法}
procedure ToChinese(hWindows: THandle; bChinese: boolean);
{*打開中文輸入法}
//數據備份
procedure BackUpData(LpBackDispMessTitle:String);
implementation {▎=======函數及過程體開始==========▎}
//▎============================================================▎//
//▎==================①擴展的字符串操作函數====================▎//
//▎============================================================▎//
// 判斷s1是否包含在s2中
function InStr(const sShort: string; const sLong: string): Boolean;
var
s1, s2: string;
begin
s1 := LowerCase(sShort);
s2 := LowerCase(sLong);
Result := Pos(s1, s2) > 0;
end;
// 擴展整數轉字符串函數，參數分別爲目標數、長度、填充字符（默認爲０）
function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string;
begin
Result := IntToStr(Value);
while Length(Result) < Len do
Result := FillChar + Result;
end;
// 帶分隔符的整數－字符轉換
function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;
var
s: string;
i, j: Integer;
begin
s := IntToStr(Value);
Result := '';
j := 0;
for i := Length(s) downto 1 do
begin
Result := s[i] + Result;
Inc(j);
try
if ((j mod SpLen) = 0) and (i <> 1) then
Result := Sp + Result;
except
MessageBox(Application.Handle,' IntToStrSp函數的第二個參數值不能爲數字0 ！',SCnError,16);
exit;
end
end;
end;
// 返回字符串右邊的字符
function StrRight(Str: string; Len: Integer): string;
begin
if Len >= Length(Str) then
Result := Str
else
Result := Copy(Str, Length(Str) - Len + 1, Len);
end;
// 返回字符串左邊的字符
function StrLeft(Str: string; Len: Integer): string;
begin
if Len >= Length(Str) then
Result := Str
else
Result := Copy(Str, 1, Len);
end;
// 字節轉二進制串
function ByteToBin(Value: Byte): string;
const
V: Byte = 1;
var
i: Integer;
begin
for i := 7 downto 0 do
if (V shl i) and Value <> 0 then
Result := Result + '1'
else
Result := Result + '0';
end;
// 返回空格串
function Spc(Len: Integer): string;
var
i: Integer;
begin
Result := '';
for i := 0 to Len - 1 do
Result := Result + ' ';
end;
// 返回將指定字符s1用字符串s2替換後的字符串，可支持大小寫敏感由CaseSensitive操作}
function Replace(Str,s1,s2:string;CaseSensitive:Boolean):string;
var
i:integer;
s,t:string;
begin
s:='';
t:=str;
repeat
if casesensitive then
i:=pos(s1,t)
else
i:=pos(lowercase(s1),lowercase(t));
if i>0 then
begin
s:=s+Copy(t,1,i-1)+s2;
t:=Copy(t,i+Length(s1),MaxInt);
end
else
s:=s+t;
until i<=0;
result:=s;
end;
function Replicate(pcChar:Char; piCount:integer):string;
begin
Result:='';
SetLength(Result,piCount);
fillChar(Pointer(Result)^,piCount,pcChar)
end;
// 返回某個字符串中某個字符串中出現的次數}
function StrNum(ShortStr:string;LongString:string):Integer; {測試通過}
var
i:Integer;
begin
i:=0;
while pos(ShortStr,LongString)>0 do
begin
i:=i+1;
LongString:=Substr(LongString,(FindStr(ShortStr,LongString))+1,Length(LongString)-FindStr(ShortStr,LongString))
end;
Result:=i;
end;
// 返回某個字符串中查找某個字符串的位置}
function FindStr(ShortStr:String;LongStrIng:String):Integer;//在一個字符串中找某個字符的位置
var
locality:integer;
begin
locality:=Pos(ShortStr,LongStrIng);
if locality=0 then
Result:=0
else
Result:=locality;
end;
// 返回從位置BeginPlace開始切取長度爲CatLeng字符串}
function SubStr(psInput:String; BeginPlace,CutLeng:Integer):String;
begin
Result:=Copy(psInput,BeginPlace,CutLeng)
end;
// 返回從左邊第一爲開始切取 CutLeng長度的字符串
function LeftStr(psInput:String; CutLeng:Integer):String;
begin
Result:=Copy(psInput,1,CutLeng)
end;
// 返回從左邊第一爲開始切取 CutLeng長度的字符串
function RightStr(psInput:String; CutLeng:Integer):String;
begin
Result:=Copy(psInput,Length(psInput)-CutLeng+1,CutLeng)
end;
{* 返回從psInput字符串左邊開始用pcPadWith填充後總長度爲PiWidth的字符串}
function PadLStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;
begin
Result:=Replicate(pcPadWith,piWidth-Length(psInput))+psInput
end;
{* 返回從psInput字符串右邊開始用pcPadWith填充後總長度爲PiWidth的字符串}
function PadRStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;
begin
Result:=psInput+Replicate(pcPadWith,piWidth-Length(psInput))
end;
{* 返回從psInput字符串兩邊開始用pcPadWith填充後總長度爲PiWidth的字符串}
function PadCStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;
var
liHalf :integer;
begin
liHalf:=(piWidth-Length(psInput))div 2;
Result:=Replicate(pcPadWith,liHalf)+psInput+Replicate(pcPadWith,piWidth-Length(psInput)-liHalf)
end;
{* 返回替換後字符串 Examples: ChrTran('abCdEgdlkh','d','#')； 返回'bC#Eg#lkh'}
function ChrTran(psInput:String; pcSearch:Char; pcTranWith:Char):String;
var
i,j:integer;
begin
j:=Length(psInput);
for i:=1 to j do
begin
if psInput[i]=pcSearch then
psInput[i]:=pcTranWith
end;
Result:=psInput
end;
{* 返回替換後字符串 Examples: StrTran('aruyfbn','ruy','====='); 返回'a=====fbn'}
function StrTran(psInput:String; psSearch:String; psTranWith:String):String;
var
liPosition,liLenOfSrch,liLenOfIn:integer;
begin
liPosition:=Pos(psSearch,psInput);
liLenOfSrch:=Length(psSearch);
liLenOfIn:=Length(psInput);
while liPosition>0 do
begin
psInput:=Copy(psInput,1,liPosition-1)
+psTranWith
+Copy(psInput,liPosition+liLenOfSrch,liLenOfIn);
liPosition:=Pos(psSearch,psInput)
end;
Result:=psInput
end;
{ *返回替換後字符串[替換字符串] Examples: Stuff('ABCDEFGHI',3,4,'12345')；返回'AB12345GHI'}
function Stuff(psInput:String; piBeginPlace,piCount:Integer; psStuffWith:String):String;
begin
Result:=Copy(psInput,1,piBeginPlace-1)+
psStuffWith+
Copy(psInput,piBeginPlace+piCount,Length(psInput))
end;
// 交換字串
procedure SwapStr(var s1, s2: string);
var
tempstr: string;
begin
tempstr := s1;
s1 := s2;
s2 := tempstr;
end;
const
csLinesCR = #13#10;
csStrCR = '/n';
// 多行文本轉單行（換行符轉'/n'）
function LinesToStr(const Lines: string): string;
var
i: Integer;
begin
Result := Lines;
i := Pos(csLinesCR, Result);
while i > 0 do
begin
system.Delete(Result, i, Length(csLinesCR));
system.insert(csStrCR, Result, i);
i := Pos(csLinesCR, Result);
end;
end;
// 單行文本轉多行（'/n'轉換行符）
function StrToLines(const Str: string): string;
var
i: Integer;
begin
Result := Str;
i := Pos(csStrCR, Result);
while i > 0 do
begin
system.Delete(Result, i, Length(csStrCR));
system.insert(csLinesCR, Result, i);
i := Pos(csStrCR, Result);
end;
end;
//字符串加密函數
function Encrypt(const S: String; Key: Word): String;
var
I : Integer;
begin
Result := S;
for I := 1 to Length(S) do
begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(Result[I]) + Key) * C1 + C2;
if Result[I] = Chr(0) then
Result[I] := S[I];
end;
Result := StrToHex(Result);
end;
//字符串解密函數
function Decrypt(const S: String; Key: Word): String;
var
I: Integer;
S1: string;
begin
S1 := HexToStr(S);
Result := S1;
for I := 1 to Length(S1) do
begin
if char(byte(S1[I]) xor (Key shr 8)) = Chr(0) then
begin
Result[I] := S1[I];
Key := (byte(Chr(0)) + Key) * C1 + C2; //保證Key的正確性
end
else
begin
Result[I] := char(byte(S1[I]) xor (Key shr 8));
Key := (byte(S1[I]) + Key) * C1 + C2;
end;
end;
end;
///VarIIF,VarTostr爲變體函數
function varIIF(aTest: Boolean; TrueValue, FalseValue: Variant): Variant;
begin
if aTest then Result := TrueValue else Result := FalseValue;
end;
function varToStr(const V: Variant): string;
begin
case TVarData(v).vType of
varSmallInt: Result := IntToStr(TVarData(v).VSmallInt);
varInteger: Result := IntToStr(TVarData(v).VInteger);
varSingle: Result := FloatToStr(TVarData(v).VSingle);
varDouble: Result := FloatToStr(TVarData(v).VDouble);
varCurrency: Result := FloatToStr(TVarData(v).VCurrency);
varDate: Result := DateToStr(TVarData(v).VDate);
varBoolean: Result := varIIf(TVarData(v).VBoolean, 'True', 'False');
varByte: Result := IntToStr(TVarData(v).VByte);
varString: Result := StrPas(TVarData(v).VString);
varEmpty,
varNull,
varVariant,
varUnknown,
varTypeMask,
varArray,
varByRef,
varDispatch,
varError: Result := '';
end;
end;
{功能說明：判斷string是否全是數字}
function IsDigital(Value: string): boolean;
var
i, j: integer;
str: char;
begin
result := true;
Value := trim(Value);
j := Length(Value);
if j = 0 then
begin
result := false;
exit;
end;
for i := 1 to j do
begin
str := Value[i];
if not (str in ['0'..'9']) then
begin
result := false;
exit;
end;
end;
end;
{隨機字符串函數}
function RandomStr(aLength : Longint) : String;
var
X : Longint;
begin
if aLength <= 0 then exit;
SetLength(Result, aLength);
for X:=1 to aLength do
Result[X] := Chr(Random(26) + 65);
end;
//▎============================================================▎//
//▎==================②擴展日期時間操作函數====================▎//
//▎============================================================▎//
function GetYear(Date: TDate): Integer;
var
y, m, d: WORD;
begin
DecodeDate(Date, y, m, d);
Result := y;
end;
function GetMonth(Date: TDate): Integer;
var
y, m, d: WORD;
begin
DecodeDate(Date, y, m, d);
Result := m;
end;
function GetDay(Date: TDate): Integer;
var
y, m, d: WORD;
begin
DecodeDate(Date, y, m, d);
Result := d;
end;
function GetHour(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := h;
end;
function GetMinute(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := m;
end;
function GetSecond(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := s;
end;
function GetMSecond(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := ms;
end;
//傳入年、月，得到該月份最後一天
function GetMonthLastDay(Cs_Year,Cs_Month:string):string;
Var
V_date:Tdate;
V_year,V_month,V_day:word;
begin
V_year:=strtoint(Cs_year);
V_month:=strtoint(Cs_month);
if V_month=12 then
begin
V_month:=1;
inc(V_year);
end
else
inc(V_month);
V_date:=EncodeDate(V_year,V_month,1);
V_date:=V_date-1;
DecodeDate(V_date,V_year,V_month,V_day);
Result:=DateToStr(EncodeDate(V_year,V_month,V_day));
end;
//判斷某年是否爲閏年
function IsLeapYear( nYear: Integer ): Boolean;
begin
Result := (nYear mod 4 = 0) and ((nYear mod 100 <> 0) or (nYear mod 400 = 0));
end;
//兩個日期取較大的日期
function MaxDateTime(const Values: array of TDateTime): TDateTime;
var
I: Cardinal;
begin
Result := Values[0];
for I := 0 to Low(Values) do
if Values[I] < Result then Result := Values[I];
end;
//兩個日期取較小的日期
function MinDateTime(const Values: array of TDateTime): TDateTime;
var
I: Cardinal;
begin
Result := Values[0];
for I := 0 to High(Values) do
if Values[I] < Result then Result := Values[I];
end;
//得到本月的第一一天
function dateBeginOfMonth(D: TDateTime): TDateTime;
var
Year, Month, Day: Word;
begin
DecodeDate(D, Year, Month, Day);
Result := EncodeDate(Year, Month, 1);
end;
//得到本月的最後一天
function dateEndOfMonth(D: TDateTime): TDateTime;
var
Year, Month, Day: Word;
begin
DecodeDate(D, Year, Month, Day);
if Month = 12 then
begin
Inc(Year);
Month := 1;
end else
Inc(Month);
Result := EncodeDate(Year, Month, 1) - 1;
end;
//得到本年的最後一天
function dateEndOfYear(D: TDateTime): TDateTime;
var
Year, Month, Day: Word;
begin
DecodeDate(D, Year, Month, Day);
Result := EncodeDate(Year, 12, 31);
end;
//得到兩個日期相隔的天數
function DaysBetween(Date1, Date2: TDateTime): integer;
begin
Result := Trunc(Date2) - Trunc(Date1) + 1;
if Result < 0 then Result := 0;
end;
//▎============================================================▎//
//▎=====================③位操作函數===========================▎//
//▎============================================================▎//
// 設置位
procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean);
begin
if IsSet then
Value := Value or (1 shl Bit)
else
Value := Value and not (1 shl Bit);
end;
procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean);
begin
if IsSet then
Value := Value or (1 shl Bit)
else
Value := Value and not (1 shl Bit);
end;
procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean);
begin
if IsSet then
Value := Value or (1 shl Bit)
else
Value := Value and not (1 shl Bit);
end;
// 取位
function GetBit(Value: Byte; Bit: TByteBit): Boolean;
begin
Result := Value and (1 shl Bit) <> 0;
end;
function GetBit(Value: WORD; Bit: TWordBit): Boolean;
begin
Result := Value and (1 shl Bit) <> 0;
end;
function GetBit(Value: DWORD; Bit: TDWordBit): Boolean;
begin
Result := Value and (1 shl Bit) <> 0;
end;
//▎============================================================▎//
//▎=================④擴展的文件及目錄操作函數=================▎//
//▎============================================================▎//
// 移動文件、目錄
function MoveFile(const sName, dName: string): Boolean;
var
s1, s2: AnsiString;
lpFileOp: TSHFileOpStruct;
begin
s1 := PChar(sName) + #0#0;
s2 := PChar(dName) + #0#0;
with lpFileOp do
begin
Wnd := Application.Handle;
wFunc := FO_MOVE;
pFrom := PChar(s1);
pTo := PChar(s2);
fFlags := FOF_ALLOWUNDO;
hNameMappings := nil;
lpszProgressTitle := nil;
fAnyOperationsAborted := True;
end;
Result := SHFileOperation(lpFileOp) = 0;
end;
// 打開文件屬性窗口
procedure FileProperties(const FName: string);
var
SEI: SHELLEXECUTEINFO;
begin
with SEI do
begin
cbSize := SizeOf(SEI);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST or
SEE_MASK_FLAG_NO_UI;
Wnd := Application.Handle;
lpVerb := 'properties';
lpFile := PChar(FName);
lpParameters := nil;
lpDirectory := nil;
nShow := 0;
hInstApp := 0;
lpIDList := nil;
end;
ShellExecuteEx(@SEI);
end;
// 縮短顯示不下的長路徑名
function FormatPath(APath: string; Width: Integer): string;
var
SLen: Integer;
i, j: Integer;
TString: string;
begin
SLen := Length(APath);
if (SLen <= Width) or (Width <= 6) then
begin
Result := APath;
Exit
end
else
begin
i := SLen;
TString := APath;
for j := 1 to 2 do
begin
while (TString[i] <> '/') and (SLen - i < Width - 8) do
i := i - 1;
i := i - 1;
end;
for j := SLen - i - 1 downto 0 do
TString[Width - j] := TString[SLen - j];
for j := SLen - i to SLen - i + 2 do
TString[Width - j] := '.';
Delete(TString, Width + 1, 255);
Result := TString;
end;
end;
// 打開文件框
function OpenDialog(var FileName: string; Title: string; Filter: string;
Ext: string): Boolean;
var
OpenName: TOPENFILENAME;
TempFilename, ReturnFile: string;
begin
with OpenName do
begin
lStructSize := SizeOf(OpenName);
hWndOwner := GetModuleHandle('');
Hinstance := SysInit.Hinstance;
lpstrFilter := PChar(Filter + #0 + Ext + #0#0);
lpstrCustomFilter := '';
nMaxCustFilter := 0;
nFilterIndex := 1;
nMaxFile := MAX_PATH;
SetLength(TempFilename, nMaxFile + 2);
lpstrFile := PChar(TempFilename);
FillChar(lpstrFile^, MAX_PATH, 0);
SetLength(TempFilename, nMaxFile + 2);
nMaxFileTitle := MAX_PATH;
SetLength(ReturnFile, MAX_PATH + 2);
lpstrFileTitle := PChar(ReturnFile);
FillChar(lpstrFile^, MAX_PATH, 0);
lpstrInitialDir := '.';
lpstrTitle := PChar(Title);
Flags := OFN_HIDEREADONLY + OFN_ENABLESIZING;
nFileOffset := 0;
nFileExtension := 0;
lpstrDefExt := PChar(Ext);
lCustData := 0;
lpfnHook := nil;
lpTemplateName := '';
end;
Result := GetOpenFileName(OpenName);
if Result then
FileName := ReturnFile
else
FileName := '';
end;
// 取兩個目錄的相對路徑,注意串尾不能是'/'字符!
function GetRelativePath(Source, Dest: string): string;
// 比較兩路徑字符串頭部相同串的函數
function GetPathComp(s1, s2: string): Integer;
begin
if Length(s1) > Length(s2) then swapStr(s1, s2);
Result := Pos(s1, s2);
while (Result = 0) and (Length(s1) > 3) do
begin
if s1 = '' then Exit;
s1 := ExtractFileDir(s1);
Result := Pos(s1, s2);
end;
if Result <> 0 then Result := Length(s1);
if Result = 3 then Result := 2;
// 修正因ExtractFileDir()處理'c:/'時產生的錯誤.
end;
// 取Dest的相對根路徑的函數
function GetRoot(s: ShortString): string;
var
i: Integer;
begin
Result := '';
for i := 1 to Length(s) do
if s[i] = '/' then Result := Result + '../';
if Result = '' then Result := './';
// 如果不想處理成"./"的路徑格式，可去掉本行
end;
var
RelativRoot, RelativSub: string;
HeadNum: Integer;
begin
Source := UpperCase(Source);
Dest := UpperCase(Dest); // 比較兩路徑字符串頭部相同串
HeadNum := GetPathComp(Source, Dest); // 取Dest的相對根路徑
RelativRoot := GetRoot(StrRight(Dest, Length(Dest) - HeadNum));
// 取Source的相對子路徑
RelativSub := StrRight(Source, Length(Source) - HeadNum - 1);
// 返回
Result := RelativRoot + RelativSub;
end;
// 運行一個文件
procedure RunFile(const FName: string; Handle: THandle;
const Param: string);
begin
ShellExecute(Handle, nil, PChar(FName), PChar(Param), nil, SW_SHOWNORMAL);
end;
// 運行一個文件並等待其結束
function WinExecAndWait32(FileName: string; Visibility: Integer): Integer;
var
zAppName: array[0..512] of Char;
zCurDir: array[0..255] of Char;
WorkDir: string;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
StrPCopy(zAppName, FileName);
GetDir(0, WorkDir);
StrPCopy(zCurDir, WorkDir);
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
zAppName, { pointer to command line string }
nil, { pointer to process security attributes }
nil, { pointer to thread security attributes }
False, { handle inheritance flag }
CREATE_NEW_CONSOLE or { creation flags }
NORMAL_PRIORITY_CLASS,
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo) then
Result := -1 { pointer to PROCESS_INF }
else
begin
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, Cardinal(Result));
end;
end;
// 應用程序路徑
function AppPath: string;
begin
Result := ExtractFilePath(Application.ExeName);
end;
// 取Windows系統目錄
function GetWindowsDir: string;
var
Buf: array[0..MAX_PATH] of Char;
begin
GetWindowsDirectory(Buf, MAX_PATH);
Result := AddDirSuffix(Buf);
end;
// 取臨時文件目錄
function GetWinTempDir: string;
var
Buf: array[0..MAX_PATH] of Char;
begin
GetTempPath(MAX_PATH, Buf);
Result := AddDirSuffix(Buf);
end;
// 目錄尾加'/'修正
function AddDirSuffix(Dir: string): string;
begin
Result := Trim(Dir);
if Result = '' then Exit;
if Result[Length(Result)] <> '/' then Result := Result + '/';
end;
function MakePath(Dir: string): string;
begin
Result := AddDirSuffix(Dir);
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 GetFileSize(FileName: string): Integer;
var
FileVar: file of Byte;
begin
{$I-}
try
AssignFile(FileVar, FileName);
Reset(FileVar);
Result := FileSize(FileVar);
CloseFile(FileVar);
except
Result := 0;
end;
{$I+}
end;
// 設置文件時間
function SetFileDate(FileName: string; CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean;
var
FileHandle: Integer;
begin
FileHandle := FileOpen(FileName, fmOpenWrite or fmShareDenyNone);
if FileHandle > 0 then
begin
SetFileTime(FileHandle, @CreationTime, @LastAccessTime, @LastWriteTime);
FileClose(FileHandle);
Result := True;
end
else
Result := False;
end;
// 取文件時間
function GetFileDate(FileName: string; var CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean;
var
FileHandle: Integer;
begin
FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
if FileHandle > 0 then
begin
GetFileTime(FileHandle, @CreationTime, @LastAccessTime, @LastWriteTime);
FileClose(FileHandle);
Result := True;
end
else
Result := False;
end;
// 取得與文件相關的圖標
// FileName: e.g. "e:/hao/a.txt"
// 成功則返回True
function GetFileIcon(FileName: string; var Icon: TIcon): Boolean;
var
SHFileInfo: TSHFileInfo;
h: HWND;
begin
if not Assigned(Icon) then
Icon := TIcon.Create;
h := SHGetFileInfo(PChar(FileName),
0,
SHFileInfo,
SizeOf(SHFileInfo),
SHGFI_ICON or SHGFI_SYSICONINDEX);
Icon.Handle := SHFileInfo.hIcon;
Result := (h <> 0);
end;
// 文件時間轉本地時間
function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;
var
STime: TSystemTime;
begin
FileTimeToLocalFileTime(FTime, FTime);
FileTimeToSystemTime(FTime, STime);
Result := STime;
end;
// 本地時間轉文件時間
function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;
var
FTime: TFileTime;
begin
SystemTimeToFileTime(STime, FTime);
LocalFileTimeToFileTime(FTime, FTime);
Result := FTime;
end;
// 創建備份文件
function CreateBakFile(FileName, Ext: string): Boolean;
var
BakFileName: string;
begin
BakFileName := FileName + '.' + Ext;
Result := CopyFile(PChar(FileName), PChar(BakFileName), False);
end;
// 刪除整個目錄
function Deltree(Dir: string): Boolean;
var
sr: TSearchRec;
fr: Integer;
begin
if not DirectoryExists(Dir) then
begin
Result := True;
Exit;
end;
fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr);
try
while fr = 0 do
begin
if (sr.Name <> '.') and (sr.Name <> '..') then
begin
if sr.Attr and faDirectory = faDirectory then
Result := Deltree(AddDirSuffix(Dir) + sr.Name)
else
Result := DeleteFile(AddDirSuffix(Dir) + sr.Name);
if not Result then
Exit;
end;
fr := FindNext(sr);
end;
finally
FindClose(sr);
end;
Result := RemoveDir(Dir);
end;
// 取文件夾文件數
function GetDirFiles(Dir: string): Integer;
var
sr: TSearchRec;
fr: Integer;
begin
Result := 0;
fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr);
while fr = 0 do
begin
if (sr.Name <> '.') and (sr.Name <> '..') then
Inc(Result);
fr := FindNext(sr);
end;
FindClose(sr);
end;
var
FindAbort: Boolean;
// 查找指定目錄下文件
procedure FindFile(const Path: string; const FileName: string = '*.*';
Proc: TFindCallBack = nil; bSub: Boolean = True; const bMsg: Boolean = True);
var
APath: string;
Info: TSearchRec;
Succ: Integer;
begin
FindAbort := False;
APath := MakePath(Path);
try
Succ := FindFirst(APath + FileName, faAnyFile - faVolumeID, Info);
while Succ = 0 do
begin
if (Info.Name <> '.') and (Info.Name <> '..') then
begin
if (Info.Attr and faDirectory) <> faDirectory then
begin
if Assigned(Proc) then
Proc(APath + Info.FindData.cFileName, Info, FindAbort);
end
else if bSub then
FindFile(APath + Info.Name, FileName, Proc, bSub, bMsg);
end;
if bMsg then Application.ProcessMessages;
if FindAbort then Exit;
Succ := FindNext(Info);
end;
finally
FindClose(Info);
end;
end;
{ 功能說明：查找一個路徑下的所有文件。
參數：path:路徑, filter:文件擴展名過濾, FileList:文件列表, ContainSubDir:是否包含子目錄}
procedure FindFileList(Path,Filter:string;FileList:TStrings;ContainSubDir:Boolean);
var
FSearchRec,DSearchRec:TSearchRec;
FindResult:shortint;
begin
FindResult:=FindFirst(path+Filter,sysutils.faAnyFile,FSearchRec);
try
while FindResult=0 do
begin
FileList.Add(FSearchRec.Name);
FindResult:=FindNext(FSearchRec);
end;
if ContainSubDir then
begin
FindResult:=FindFirst(path+Filter,faDirectory,DSearchRec);
while FindResult=0 do
begin
if ((DSearchRec.Attr and faDirectory)=faDirectory)
and (DSearchRec.Name<>'.') and (DSearchRec.Name<>'..') then
FindFileList(Path,Filter,FileList,ContainSubDir);
FindResult:=FindNext(DSearchRec);
end;
end;
finally
FindClose(FSearchRec);
end;
end;
//返回一文本文件的行數
function Txtline(const txt: string): integer;
var
F : TextFile; {設定爲文本文件}
StrLine : string; {每行字符串}
line : Integer; {行數}
begin
AssignFile(F, txt); {建立文件}
Reset(F);
Line := 0;
while not SeekEof(f) do {文件沒到尾}
begin
if SeekEoln(f) then {判斷是否到行尾}
Readln;
Readln(F, StrLine);
if SeekEof(f) then
break
else
inc(Line);
end;
CloseFile(F); {關閉文件}
Result := Line;
end;
//Html文件轉化成文本文件
function Html2Txt(htmlfilename: string): string;
var Mystring:TStrings;
s,lineS:string;
line,Llen,i,j:integer;
rloop:boolean;
begin
rloop:=False;
Mystring:=TStringlist.Create;
s:='';
Mystring.LoadFromFile(htmlfilename);
line:=Mystring.Count;
try
for i:=0 to line-1 do
Begin
lineS:=Mystring[i];
Llen:=length(lineS);
j:=1;
while (j<=Llen)and(lineS[j]=' ')do
begin
j:=j+1;
s:=s+' ';
End;
while j<=Llen do
Begin
if lineS[j]='<'then
rloop:=True;
if lineS[j]='>'then
Begin
rloop:=False;
j:=j+1;
continue;
End;
if rloop then
begin
j:=j+1;
continue;
end
else
s:=s+lineS[j];
j:=j+1;
End;
s:=s+#13#10;
End;
finally
Mystring.Free;
end;{try}
result:=s;
end;
// 文件打開方式
function OpenWith(const FileName: string): Integer;
begin
Result := ShellExecute(Application.Handle, 'open', 'rundll32.exe',
PChar('shell32.dll,OpenAs_RunDLL ' + FileName), '', SW_SHOW);
end;
//▎============================================================▎//
//▎===================⑤擴展的對話框函數=======================▎//
//▎============================================================▎//
// 顯示提示窗口
procedure InfoDlg(Mess: string; Caption: string; Flags: Integer);
begin
Application.MessageBox(PChar(Mess), PChar(Caption), Flags);
end;
// 顯示提示確認窗口
function InfoOk(Mess: string; Caption: string): Boolean;
begin
Result := Application.MessageBox(PChar(Mess), PChar(Caption),
MB_OK + MB_ICONINFORMATION) = IDOK;
end;
// 顯示錯誤窗口
procedure ErrorDlg(Mess: string; Caption: string);
begin
Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONSTOP);
end;
// 顯示警告窗口
procedure WarningDlg(Mess: string; Caption: string);
begin
Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONWARNING);
end;
// 顯示查詢是否窗口
function QueryDlg(Mess: string; Caption: string): Boolean;
begin
Result := Application.MessageBox(PChar(Mess), PChar(Caption),
MB_YESNO + MB_ICONQUESTION) = IDYES;
end;
//窗體漸變
procedure SetWindowAnimate(Sender : TForm; IsSetAni : bool);
var
pOSVersionInfo : OSVersionInfo;
begin
pOSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo);
GetVersionEx(pOSVersionInfo);
if pOSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then
begin
if IsSetAni then
AnimateWindow(Sender.Handle,444,AW_HIDE or AW_BLEND);
end
else
if IsSetAni then
begin
AnimateWindow(Sender.Handle,444,AW_HIDE or AW_CENTER);
end;
end;
//▎============================================================▎//
//▎====================⑥ 系統功能函數 =======================▎//
//▎============================================================▎//
// 移動鼠標到控件
procedure MoveMouseIntoControl(AWinControl: TControl);
var
rtControl: TRect;
begin
rtControl := AWinControl.BoundsRect;
MapWindowPoints(AWinControl.Parent.Handle, 0, rtControl, 2);
SetCursorPos(rtControl.Left + (rtControl.Right - rtControl.Left) div 2,
rtControl.Top + (rtControl.Bottom - rtControl.Top) div 2);
end;
// 動態設置分辨率
function DynamicResolution(x, y: WORD): Boolean;
var
lpDevMode: TDeviceMode;
begin
Result := EnumDisplaySettings(nil, 0, lpDevMode);
if Result then
begin
lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
lpDevMode.dmPelsWidth := x;
lpDevMode.dmPelsHeight := y;
Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;
end;
end;
// 窗口最上方顯示
procedure StayOnTop(Handle: HWND; OnTop: Boolean);
const
csOnTop: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST);
begin
SetWindowPos(Handle, csOnTop[OnTop], 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
end;
var
WndLong: Integer;
// 設置程序是否出現在任務欄
procedure SetHidden(Hide: Boolean);
begin
ShowWindow(Application.Handle, SW_HIDE);
if Hide then
SetWindowLong(Application.Handle, GWL_EXSTYLE,
WndLong or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW or WS_EX_TOPMOST)
else
SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong);
ShowWindow(Application.Handle, SW_SHOW);
end;
const
csWndShowFlag: array[Boolean] of DWORD = (SW_HIDE, SW_RESTORE);
// 設置任務欄是否可見
procedure SetTaskBarVisible(Visible: Boolean);
var
wndHandle: THandle;
begin
wndHandle := FindWindow('Shell_TrayWnd', nil);
ShowWindow(wndHandle, csWndShowFlag[Visible]);
end;
// 設置桌面是否可見
procedure SetDesktopVisible(Visible: Boolean);
var
hDesktop: THandle;
begin
hDesktop := FindWindow('Progman', nil);
ShowWindow(hDesktop, csWndShowFlag[Visible]);
end;
// 顯示等待光標
procedure BeginWait;
begin
Screen.Cursor := crHourGlass;
end;
// 結束等待光標
procedure EndWait;
begin
Screen.Cursor := crDefault;
end;
// 檢測是否Win95/98平臺
function CheckWindows9598NT: String;
var
V: TOSVersionInfo;
begin
V.dwOSVersionInfoSize := SizeOf(V);
Result := '未知操作系統';
if not GetVersionEx(V) then Exit;
if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
Result := 'Windows 95/98'
else
begin
if V.dwPlatformId = VER_PLATFORM_WIN32_NT then
Result := 'Windows NT'
else
Result :='Windows'
end;
end;
{* 取得當前操作平臺是 Windows 95/98 還是NT}
function GetOSInfo : String;
begin
Result := '';
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS: Result := 'Windows 95/98';
VER_PLATFORM_WIN32_NT: Result := 'Windows NT';
else
Result := 'Windows32';
end;
end;
//*獲取當前Windows登錄名的用戶
function GetCurrentUserName : string;
const
cnMaxUserNameLen = 254;
var
sUserName : string;
dwUserNameLen : Dword;
begin
dwUserNameLen := cnMaxUserNameLen-1;
SetLength( sUserName, cnMaxUserNameLen );
GetUserName(Pchar( sUserName ), dwUserNameLen );
SetLength( sUserName, dwUserNameLen );
Result := sUserName;
end;
function GetRegistryOrg_User(UserKeyType:string):string;
var
Myreg:Tregistry;
RegString:string;
begin
MyReg:=Tregistry.Create;
MyReg.RootKey:=HKEY_LOCAL_MACHINE;
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
RegString:='Software/Microsoft/Windows NT/CurrentVersion'
else
RegString:='Software/Microsoft/Windows/CurrentVersion';
if MyReg.openkey(RegString,False) then
begin
if UpperCase(UserKeyType)='REGISTEREDORGANIZATION' then
Result:= MyReg.readstring('RegisteredOrganization')
else
begin
if UpperCase(UserKeyType)='REGISTEREDOWNER' then
Result:= MyReg.readstring('RegisteredOwner')
else
Result:='';
end;
end;
MyReg.CloseKey;
MyReg.Free;
end;
//獲取操作系統版本號
function GetSysVersion:string;
Var
OSVI:OSVERSIONINFO;
ObjSysVersion:string;
begin
OSVI.dwOSversioninfoSize:=Sizeof(OSVERSIONINFO);
GetVersionEx(OSVI);
ObjSysVersion:=IntToStr(OSVI.dwMinorVersion)+','+IntToStr(OSVI.dwMinorVersion)+','
+IntToStr(OSVI.dwBuildNumber)+','+IntToStr(OSVI.dwPlatformId)+','
+OSVI.szCSDVersion;
if rightstr(ObjSysVersion,1)=',' then
ObjSysVersion:=Substr(ObjSysVersion,1,length(ObjSysVersion)-1);
Result:=ObjSysVersion;
end;
//Windows啓動模式
function WinBootMode:string;
begin
case(GetSystemMetrics(SM_CLEANBOOT)) of
0:Result:='正常模式啓動';
1:Result:='安全模式啓動';
2:Result:='安全模式啓動，但附帶網絡功能';
else
Result:='錯誤：系統啓動有問題。';
end;
end;
////Windows ShutDown等
procedure WinShutDown(ShutWinType:PShutType; PForce:Boolean);
var
hToken, hProcess: THandle;
tp, prev_tp: TTokenPrivileges;
Len, Flags: DWORD;
CanShutdown: Boolean;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
hProcess := OpenProcess(PROCESS_ALL_ACCESS, True, GetCurrentProcessID);
try
if not OpenProcessToken(hProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
Exit;
finally
CloseHandle(hProcess);
end;
try
if not LookupPrivilegeValue('', 'SeShutdownPrivilege',
tp.Privileges[0].Luid) then Exit;
tp.PrivilegeCount := 1;
tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
if not AdjustTokenPrivileges(hToken, False, tp, SizeOf(prev_tp),
prev_tp, Len) then Exit;
finally
CloseHandle(hToken);
end;
end;
CanShutdown := True;
// DoQueryShutdown(CanShutdown);
if not CanShutdown then Exit;
if PForce then Flags := EWX_FORCE else Flags := 0;
case ShutWinType of
UPowerOff: ExitWindowsEx(Flags or EWX_POWEROFF, 0);
UShutdown: ExitWindowsEx(Flags or EWX_SHUTDOWN, 0);
UReboot: ExitWindowsEx(Flags or EWX_REBOOT, 0);
ULogoff: ExitWindowsEx(Flags or EWX_LOGOFF, 0);
USuspend: SetSystemPowerState(True, PForce);
UHibernate: SetSystemPowerState(False, PForce);
end;
end;
//▎============================================================▎//
//▎=====================⑦硬件功能函數=========================▎//
//▎============================================================▎//
function GetClientGUID:string;
var
myGuid:TGUID;
ResultStr:string;
begin
CreateGuid(myGuid);
ResultStr:=GUIDToString(myGuid);
ResultStr:=Communal.Replace(ResultStr,'-','',False);
ResultStr:=Communal.Replace(ResultStr,'{','',False);
ResultStr:=Communal.Replace(ResultStr,'}','',False);
Result:=Substr(ResultStr,1,30);
end;
// 聲卡是否存在
function SoundCardExist: Boolean;
begin
Result := WaveOutGetNumDevs > 0;
end;
//* 獲取磁盤序列號
function GetDiskSerial(DiskChar: Char): string;
var
SerialNum : pdword;
a, b : dword;
Buffer : array [0..255] of char;
begin
result := '';
if GetVolumeInformation(PChar(diskchar+':/'), Buffer, SizeOf(Buffer), SerialNum,a, b, nil, 0) then
Result := IntToStr(SerialNum^);
end;
//*檢查磁盤準備是否就緒
function DiskReady(Root: string) : Boolean;
var
Oem : CARDINAL ;
Dw1,Dw2 : DWORD ;
begin
Oem := SetErrorMode( SEM_FAILCRITICALERRORS ) ;
if LENGTH(Root) = 1 then Root := Root + '://';
Result := GetVolumeInformation( PCHAR( Root ), NIL,0,NIL, Dw1,Dw2, NIL,0 ) ;
SetErrorMode( Oem ) ;
end;
//*檢查驅動器A中磁盤的是否有文件及文件狀態
function DriveState (driveletter: Char) : TDriveState;
var
mask: String[6];
sRec: TSearchRec;
oldMode: Cardinal;
retcode: Integer;
begin
oldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
mask:= '?:/*.*';
mask[1] := driveletter;
{$I-}
retcode := FindFirst (mask, faAnyfile, Srec);
FindClose(Srec);
{$I+}
case retcode of
0 : Result := DSDISK_WITHFILES; //磁盤有文件
-18 : Result := DSEMPTYDISK; //好的空磁盤
-21, -3: Result := DSNODISK; //NT,Win31的錯誤代號
else
Result := DSUNFORMATTEDDISK;
end;
SetErrorMode(oldMode);
end;
//寫串口
procedure WritePortB( wPort : Word; bValue : Byte );
begin
asm
mov dx, wPort
mov al, bValue
out dx, al
end;
end;
//讀串口
function ReadPortB( wPort : Word ):Byte;
begin
asm
mov dx, wPort
in al, dx
mov result, al
end;
end;
//獲知當前機器CPU的速率（MHz）
function CPUSpeed: Double;
const
DelayTime = 500;
var
TimerHi, TimerLo: DWORD;
PriorityClass, Priority: Integer;
begin
PriorityClass := GetPriorityClass(GetCurrentProcess);
Priority := GetThreadPriority(GetCurrentThread);
SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);
Sleep(10);
asm
dw 310Fh
mov TimerLo, eax
mov TimerHi, edx
end;
Sleep(DelayTime);
asm
dw 310Fh
sub eax, TimerLo
sbb edx, TimerHi
mov TimerLo, eax
mov TimerHi, edx
end;
SetThreadPriority(GetCurrentThread, Priority);
SetPriorityClass(GetCurrentProcess, PriorityClass);
Result := TimerLo / (1000.0 * DelayTime);
end;
//獲取CPU的標識ID號
function GetCPUID : TCPUID; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Resukt}
MOV EAX,1
DW $A20F {CPUID Command}
STOSD {CPUID[1]}
MOV EAX,EBX
STOSD {CPUID[2]}
MOV EAX,ECX
STOSD {CPUID[3]}
MOV EAX,EDX
STOSD {CPUID[4]}
POP EDI {Restore registers}
POP EBX
end;
//獲取計算機的物理內存
function GetMemoryTotalPhys : Dword;
var
memStatus: TMemoryStatus;
begin
memStatus.dwLength := sizeOf ( memStatus );
GlobalMemoryStatus ( memStatus );
Result := memStatus.dwTotalPhys div 1024;
end;
//▎============================================================▎//
//▎=====================⑧網絡功能函數=========================▎//
//▎============================================================▎//
{* 獲取網絡計算機名稱}
function GetComputerName:string;
var
wVersionRequested : WORD;
wsaData : TWSAData;
p : PHostEnt; s : array[0..128] of char;
begin
try
wVersionRequested := MAKEWORD(1, 1); //創建 WinSock
WSAStartup(wVersionRequested, wsaData); //創建 WinSock
GetHostName(@s,128);
p:=GetHostByName(@s);
Result:=p^.h_Name;
finally
WSACleanup; //釋放 WinSock
end;
end;
{* 獲取計算機的IP地址}
function GetHostIP:string;
var
wVersionRequested : WORD;
wsaData : TWSAData;
p : PHostEnt; s : array[0..128] of char; p2 : pchar;
begin
try
wVersionRequested := MAKEWORD(1, 1); //創建 WinSock
WSAStartup(wVersionRequested, wsaData); //創建 WinSock
GetHostName(@s,128);
p:=GetHostByName(@s);
p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
Result:= P2;
finally
WSACleanup; //釋放 WinSock
end;
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
Result:='';
i := 1;
while i <= Length(AHzStr) do
begin
if (AHzStr[i] >= #160) and (AHzStr[i + 1] >= #160) then
begin
HzOrd := (Ord(AHzStr[i]) - 160) * 100 + Ord(AHzStr[i + 1]) - 160;
for j := 0 to 25 do
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[i];
Inc(i);
end;
end;
{* 判斷一個字符串中有多少各漢字}
function HowManyChineseChar(Const s:String):Integer;
var
SW:WideString;
C:String;
i, WCount:Integer;
begin
SW:=s;
WCount:=0;
For i:=1 to Length(SW) do
begin
c:=SW[i];
if Length(c)>1 then
Inc(WCount);
end;
Result:=WCount;
end;
//▎============================================================▎//
//▎==================⑩數據庫功能函數及過程====================▎//
//▎============================================================▎//
//* 物理刪除數據庫(Db，Dbf)中的數據[着了刪除標記的記錄]}
{function PackDbDbf(Var StatusMsg: String): Boolean;
var
rslt:DBIResult;
szErrMsg:DBIMSG;
pTblDesc:pCRTblDesc;
bExclusive:Boolean;
bActive:Boolean;
isParadox,isDbase:Boolean;
tempTableName:string;
Props:CurProps;//保護口令
begin
Result:=False;
StatusMsg:='';
if TableType=ttDefault then
begin
tempTableName:=TableName;
tempTableName:=Lowercase(tempTableName);
isParadox:=(pos('.db',tempTableName)>0) and (tempTableName[length(tempTableName)]='b');
isDbase:=pos('.dbf',tempTableName)>0;
end
else
begin
isParadox:=TableType=ttParadox;
isDbase:=TableType=ttDbase;
end;
if isparadox or isDbase then
begin
bExclusive:=Exclusive;
bActive:=Active;
DisableControls;
// Close;
Exculsive:=true;
end
else
begin
StatusMsg:='無效的數據表類型。';
Exit;
end;
if isParadox then
begin
if wwMemAvail(Sizeof(CRTblDesc)) then
begin
StatusMsg:='內存不足，壓縮表失敗。';
end
else
begin
GetMem(pTblDesc,Sizeof(CRTblDesc));
fillchar(pTblDesc^,Sizeof(CRTblDesc),0);
with pTblDesc^ do
begin
strCopy(szTblName,Tablename);
strCopy(szTblType,szParadox);
Active:=True;
Check(DbiGetCursorProps(handle,Props));//檢測是否右口令保護
bProtected:=props.bProtected;
Active:=False;
bPack:=True;
end;
Screen.Cursor:=crHourGlass;
SetDBFlag(dbfOpened,True);
rslt:=DBIdoRestructure(DBHandle,1,pTblDesc,nil,nil,nil,False);
if rslt<>DBIERR_NONE then
begin
DBiGetErrorString(rslt,SzErrMsg);
StatusMsg:=SzErrMsg;
end
else
Result:=True;
SetDBFlag(dbfOpened,False);
FreeMem(pTblDesc,Sizeof(CRTlDesc));
Screen.Cursor:=crDefault;
end;
end
else
if isDbase then
begin
Screen.Cursor:=crHourGlass;
OPen;
rslt:=dbiPacktable(DBHandle,Handle,nil,nil,True);
Screen.Cursor:=crDefault;
if rslt<>DBIERR_NONE then
begin
DBiGetERRorString(rslt,szErrMsg);
StatusMSg:=SzErrMsg;
end
else
Result:=True;
end;
Close;
Exculsive:=bExclusive;
Active:=bActive;
EnableControls;
end;}
{procedure CompactDb(DbName, NewDbName: string);
var
dao: OLEVariant;
begin
dao := CreateOleObject('DAO.DBEngine.35');
dao.CompactDatabase(DbName, NewDbName);
end;}
//修復Access表
procedure RepairDb(DbName: string);
var
Dao: OLEVariant;
begin
Dao := CreateOleObject('DAO.DBEngine.35');
Dao.RepairDatabase(DbName);
end;
//通過註冊表創建ODBC配置[創建在系統DSN頁下]
function CreateODBCCfgInRegistry(ODBCSourceName:WideString; ServerName, DataBaseDescription:String):boolean;
var
Reg: TRegistry;
LPT_systemDir:array [1..255] of char;
P:Pchar;
DriverString:String;
begin
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
try
try
if not Reg.KeyExists('/Software/ODBC/ODBC.INI/'+trim(ODBCSourceName)) then
begin
//創建並打開主鍵。
if Reg.OpenKey('/Software/ODBC/ODBC.INI/'+trim(ODBCSourceName),True) then
begin
//寫入鍵值
Reg.WriteString('DataBase', ODBCSourceName);
Reg.WriteString('Description',Trim(DataBaseDescription));
GetSystemDirectory(@LPT_systemDir,255) ;
P:=@LPT_systemDir;
DriverString:=StrCat(P,Pchar('/SQLSRV32.DLL')) ;
Reg.WriteString('Driver', DriverString);
Reg.WriteString('LastUser', 'Administrator');
Reg.WriteString('Server', trim(ServerName));
Reg.WriteString('Trusted_Connection', 'Yes');
reg.CloseKey;
end;
//加入ODBCDataSource
if Reg.OpenKey('/Software/ODBC/ODBC.INI/ODBC Data Sources/',True) then
begin
Reg.DeleteValue(ODBCSourceName);
Reg.WriteString(ODBCSourceName, 'SQL Server');
Reg.CloseKey;
end;
end;
Result:=True;
except
Result:=False;
end;
finally
Reg.Free;
end;
end;
function ADOConnectSysBase(Const Adocon:TadoConnection):boolean;
{* 用Ado連接SysBase數據庫函數}
begin
with Adocon do
begin
Close;
LoginPrompt:=False; //若數據庫不存在時，進行判斷。。。。。。
ConnectionString:='Provider=MSDASQL.1;'+
'Password="";'+
'Persist Security Info=True;'+
'Data Source=Sy_Finalact';
try
KeepConnection:=True;
Screen.Cursor:=crHourGlass;
Connected:=True;
Open;
Screen.Cursor:=crDefault;
ADOConnectSysBase:=True;
except
ADOConnectSysBase:=False;
end;
end;
end;
//Ado連接數據庫函數
function ADOConnectLocalDB(Const Adocon:TAdoConnection;Const Dbname,DBServerName:String;ValidateMode:Integer):boolean;
begin
with Adocon do
begin
Close;
LoginPrompt:=False; //若數據庫不存在時，進行判斷。。。。。。
if ValidateMode=0 then//使用Windows NT驗證模式
ConnectionString:='Provider=SQLOLEDB.1;'+
'Password="";'+
'Integrated Security=SSPI;'+ //集成安全
'Persist Security Info=False;'+
'User ID=sa;Initial Catalog='+''''+dbname+''''+';'+
'Data Source='+''''+DBServerName+'''';
if ValidateMode=1 then//使用SQL SERVER驗證模式
ConnectionString:='Provider=SQLOLEDB.1;'+
'Password="";'+
'Persist Security Info=True;'+
'User ID=sa;Initial Catalog='+''''+Dbname+''''+';'+
'Data Source='+''''+DBServerName+'''';
try
KeepConnection:=True;
Screen.Cursor:=crHourGlass;
Connected:=True;
Open;
Screen.Cursor:=crDefault;
ADOConnectLocalDB:=True;
except
ADOConnectLocalDB:=False;
end;
end;
end;
//Ado與ODBC共同連接數據庫函數
function ADOODBCConnectLocalDB(Const Adocon:TAdoConnection;Const Dbname:String;ValidateMode:Integer):boolean;
begin
with Adocon do
begin
Close;
LoginPrompt:=False; //若數據庫不存在時，進行判斷。。。。。。
if ValidateMode=0 then//使用Windows NT驗證模式
ConnectionString:='Provider=MSDASQL.1;'+
'Password="";'+
'Persist Security Info=False;'+
'User ID=sa;Data Source='+''''+DBName+''''+';'+
'Initial Catalog='+''''+DBname+'''';
if ValidateMode=1 then//使用SQL SERVER驗證模式
ConnectionString:='Provider=MSDASQL.1;'+
'Password="";'+
'Persist Security Info=True;'+
'User ID=sa;Data Source='+''''+DBName+''''+';'+
'Initial Catalog='+''''+DBname+'''';
try
KeepConnection:=True;
Screen.Cursor:=crHourGlass;
Connected:=True;
Open;
Screen.Cursor:=crDefault;
ADOODBCConnectLocalDB:=True;
except
ADOODBCConnectLocalDB:=False;
end;
end;
end;
///在指定的數據庫中建立表
function CreatTable(LpDataBaseName,LpTableName,LpSentence:string):Boolean;//建立新表
Var
CreatTableQuery:TQuery;
SQLsentence:string;
Successed:Boolean;//成功否
begin
Successed:=False;
SQLsentence:='CREATE TABLE "'+ LpTableName +'" ' + LpSentence;
CreatTableQuery:=TQuery.Create(nil);
try
try
with CreatTableQuery do
begin
UniDirectional:=True;
Active:=False;
Sql.Clear;
DataBaseName := LpDataBaseName; //數據庫名
Sql.Add(SQLsentence);
ExecSQL;
Successed:=True;
end;
except
MessageBox(Application.Handle,Pchar(' 在建立數據庫 '+Trim(LpDataBaseName)+' 中的 '+Trim(LpTableName)+' 表出錯，建立未能成功 ！'),'建立失敗',0+16);
Successed:=False;
end;
finally
CreatTableQuery.Free;//釋放建立的Query
if Successed then
Result:=True//建立成功
else
Result:=False;//建立失敗
end;
end;
//在指定的表中新填字段
function AddField(LpFieldName:string; LpDataType: TFieldType; LpSize: Word):string;//建立新表
var
Sentence,SQLsentence : string;
begin
Sentence:= '';
SQLsentence:='';
if LpFieldName = '' then
raise EDBUpdateErr.Create('字段名不能爲空');
if Pos(' ', LpFieldName) <> 0 then
raise EDBUpdateErr.Create('字段名中不能含有空格字符');
if LpDataType = ftString then
sentence := 'ADD '+LpFieldName+' Char('+ IntToStr( LpSize ) + ')';
if LpDataType = ftInteger then
sentence := 'ADD '+LpFieldName+' Integer';
if LpDataType = ftSmallInt then
sentence := 'ADD '+LpFieldName+' SmallInt';
if LpDataType = ftFloat then
sentence := 'ADD '+LpFieldName+' Float('+ IntToStr( LpSize ) +',0)';
if LpDataType = ftDate then
sentence := 'ADD '+LpFieldName+' Date';
if LpDataType = ftTime then
sentence := 'ADD '+LpFieldName+' Time';
if LpDataType = ftDateTime then
sentence := 'ADD '+LpFieldName+' TimeStamp';
if sentence = '' then
raise EDBUpdateErr.Create('無效的字段類型');
if SQLSentence = '' then
SQLSentence := sentence
else
SQLSentence := SQLSentence + ', ' + sentence;
Result:=SQLSentence;//返回SQL句體
end;
//在指定的表中刪除字段
function KillField(LpFieldName:string):String;//刪除表中的字段
var
SQLsentence : string;
begin
if LpFieldName = '' then
raise EDBUpdateErr.Create('字段名不能爲空');
if Pos(' ', LpFieldName) <> 0 then
raise EDBUpdateErr.Create('字段名中不能含有空格字符');
if SQLSentence = '' then
SQLSentence := 'DROP COLUMN ' + LpFieldName
else
SQLSentence := SQLSentence + ', DROP ' + LpFieldName;
Result:=SQLSentence;
end;
//修改表結構的SQL語句執行體
function AlterTableExec(LpDataBaseName,LpSentence:string):Boolean;//修改表結構
var
AlterQueryTable:TQuery;
Successed:Boolean;//成功否
begin
Successed:=False;
AlterQueryTable:= TQuery.Create(nil);
try
try
with AlterQueryTable do
begin
DataBaseName:=LpDataBaseName;//數據庫名
UniDirectional:=True;
Active:=False;
Sql.Clear;
Sql.Add(LpSentence);
ExecSQL;
Successed:=True;
end;
except
Successed:=False;
end;
finally
AlterQueryTable.Free;
if successed then
Result:=True
else
Result:=False;
end;
end;
//修改、添加、刪除表結構時的SQL句體
function GetSQLSentence(LpTableName,LpSQLsentence:string): string;
begin
Result := 'ALTER TABLE "'+ LpTableName +'" ' + LpSQLSentence + ';';
end;
//▎============================================================▎//
//▎======================⑾進制函數及過程======================▎//
//▎============================================================▎//
//字符轉化成十六進制
function StrToHex(AStr: string): string;
var
I : Integer;
// Tmp: string;
begin
Result := '';
For I := 1 to Length(AStr) do
begin
Result := Result + Format('%2x', [Byte(AStr[I])]);
end;
I := Pos(' ', Result);
While I <> 0 do
begin
Result[I] := '0';
I := Pos(' ', Result);
end;
end;
//十六進制轉化成字符
function HexToStr(AStr: string): string;
var
I : Integer;
CharValue: Word;
begin
Result := '';
for I := 1 to Trunc(Length(Astr)/2) do
begin
Result := Result + ' ';
CharValue := TransChar(AStr[2*I-1])*16 + TransChar(AStr[2*I]);
Result[I] := Char(CharValue);
end;
end;
function TransChar(AChar: Char): Integer;
begin
if AChar in ['0'..'9'] then
Result := Ord(AChar) - Ord('0')
else
Result := 10 + Ord(AChar) - Ord('A');
end;
//▎============================================================▎//
//▎=====================⑿其它函數及過程=======================▎//
//▎============================================================▎//
// 輸出限制在Min..Max之間
function TrimInt(Value, Min, Max: Integer): Integer; overload;
begin
if Value > Max then
Result := Max
else if Value < Min then
Result := Min
else
Result := Value;
end;
// 輸出限制在0..255之間
function IntToByte(Value: Integer): Byte; overload;
asm
OR EAX, EAX
JNS @@Positive
XOR EAX, EAX
RET
@@Positive:
CMP EAX, 255
JBE @@OK
MOV EAX, 255
@@OK:
end;
// 由TRect分離出座標、寬高
procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);
begin
x := Rect.Left;
y := Rect.Top;
Width := Rect.Right - Rect.Left;
Height := Rect.Bottom - Rect.Top;
end;
// 比較兩個Rect
function RectEqu(Rect1, Rect2: TRect): Boolean;
begin
Result := (Rect1.Left = Rect2.Left) and (Rect1.Top = Rect2.Top) and
(Rect1.Right = Rect2.Right) and (Rect1.Bottom = Rect2.Bottom);
end;
// 產生TSize類型
function EnSize(cx, cy: Integer): TSize;
begin
Result.cx := cx;
Result.cy := cy;
end;
// 計算Rect的寬度
function RectWidth(Rect: TRect): Integer;
begin
Result := Rect.Right - Rect.Left;
end;
// 計算Rect的高度
function RectHeight(Rect: TRect): Integer;
begin
Result := Rect.Bottom - Rect.Top;
end;
// 判斷範圍
function InBound(Value: Integer; Min, Max: Integer): Boolean;
begin
Result := (Value >= Min) and (Value <= Max);
end;
// 交換兩個數
procedure CnSwap(var A, B: Byte); overload;
var
Tmp: Byte;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Integer); overload;
var
Tmp: Integer;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Single); overload;
var
Tmp: Single;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Double); overload;
var
Tmp: Double;
begin
Tmp := A;
A := B;
B := Tmp;
end;
// 延時
procedure Delay(const uDelay: DWORD);
var
n: DWORD;
begin
n := GetTickCount;
while ((GetTickCount - n) <= uDelay) do
Application.ProcessMessages;
end;
// 在Win9X下讓喇叭發聲
procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
const
FREQ_SCALE = $1193180;
var
Temp: WORD;
begin
Temp := FREQ_SCALE div Freq;
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);
asm
in al,$61;
and al,$fc;
out $61,al;
end;
end;
// 顯示Win32 Api運行結果信息
procedure ShowLastError;
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 StrCopy(@Buf, PChar(SUnknowError));
MessageBox(Application.Handle, PChar(string(Buf) + #10#13 +
SErrorCode + IntToStr(ErrNo)),
SCnInformation, MB_OK + MB_ICONINFORMATION);
end;
//將字體Font.Style寫入INI文件
function writeFontStyle(FS: TFontStyles; inifile: string; write: boolean):string;
var
Mystyle : string;
Myini : Tinifile;
begin
Mystyle := '[';
if fsBold in FS then MyStyle := MyStyle + 'fsBold';
if fsItalic in FS then
if MyStyle = '[' then
MyStyle := MyStyle + 'fsItalic'
else
MyStyle := MyStyle + ',fsItalic';
if fsUnderline in FS then
if MyStyle = '[' then
MyStyle := MyStyle + 'fsUnderline'
else
MyStyle := MyStyle + ',fsUnderline';
if fsStrikeOut in FS then
if MyStyle = '[' then
MyStyle := MyStyle + 'fsStrikeOut'
else
MyStyle := MyStyle + ',fsStrikeOut';
MyStyle := MyStyle + ']';
if write then
begin
Myini := TInifile.Create(inifile);
Myini.WriteString('FontStyle', 'style', MyStyle);
Myini.free;
end;
Result := MyStyle;
end;
//從INI文件中讀取字體Font.Style文件
function readFontStyle(inifile: string): TFontStyles;
var
MyFontStyle : TFontStyles;
MyStyle : string;
Myini : Tinifile;
begin
MyFontStyle := [];
Myini := TInifile.Create(inifile);
Mystyle := Myini.ReadString('Fontstyle', 'style', '[]');
if pos('fsBold', Mystyle) > 0 then MyFontStyle := MyFontStyle + [fsBold];
if Pos('fsItalic', MyStyle) > 0 then MyFontStyle := MyFontStyle + [fsItalic];
if Pos('fsUnderline', MyStyle) > 0 then
MyFontStyle := MyFontStyle + [fsUnderline];
if Pos('fsStrikeOut', MyStyle) > 0 then
MyFontStyle := MyFontStyle + [fsStrikeOut];
MyIni.free;
Result := MyFontStyle;
end;
//*取得TMemo 控件當前光標的行和列信息到Tpoint中
//function ReadCursorPos(SourceMemo: TMemo): TPoint;
function ReadCursorPos(SourceMemo: TMemo): string;
var
// Point: TPoint;
X,Y:integer;
begin
// point.y := SendMessage(SourceMemo.Handle, EM_LINEFROMCHAR,SourceMemo.SelStart,0);
// point.x := SourceMemo.SelStart- SendMessage(SourceMemo.Handle,EM_LINEINDEX,point.y,0);
y := SendMessage(SourceMemo.Handle, EM_LINEFROMCHAR,SourceMemo.SelStart,0);
x := SourceMemo.SelStart- SendMessage(SourceMemo.Handle,EM_LINEINDEX,y,0);
Result := '行:'+inttostr(y+1)+' '+'列:'+inttostr(x+1);
end;
//*檢查Tmemo控件能否Undo功能
function CanUndo(AMemo: TMemo): Boolean;
begin
Result :=AMemo.Perform(EM_CANUNDO, 0, 0)<>0;
end;
//* 實現Undo功能
procedure Undo(Amemo: Tmemo);
begin
Amemo.Perform(EM_UNDO, 0, 0);
end;
//* 實現ComBoBox自動下拉
procedure AutoListDisplay(ACombox:TComboBox);
begin
SendMessage(ACombox.handle, CB_SHOWDROPDOWN, Integer(True), 0);
end;
//* 小寫金額轉換爲大寫
function UpperMoney(small:real):string;
var
SmallMonth,BigMonth:string;
wei1,qianwei1:string[2];
qianwei,dianweizhi,qian:integer;
ObjSmall:real;
begin
{------- 修改參數令值更精確 -------}
ObjSmall:=Abs(small);
qianwei:=-2;{小數點後的位置，需要的話也可以改動-2值}
Smallmonth:=formatfloat('0.00',ObjSmall);{轉換成貨幣形式，需要的話小數點後加多幾個零}
{---------------------------------}
dianweizhi :=pos('.',Smallmonth);{小數點的位置}
for qian:=length(Smallmonth) downto 1 do{循環小寫貨幣的每一位，從小寫的右邊位置到左邊}
begin
if qian<>dianweizhi then{如果讀到的不是小數點就繼續}
begin
case strtoint(copy(Smallmonth,qian,1)) of{位置上的數轉換成大寫}
1:wei1:='壹';
2:wei1:='貳';
3:wei1:='叄';
4:wei1:='肆';
5:wei1:='伍';
6:wei1:='陸';
7:wei1:='柒';
8:wei1:='捌';
9:wei1:='玖';
0:wei1:='零';
end;
case qianwei of{判斷大寫位置，可以繼續增大到real類型的最大值}
-3:qianwei1:='釐';
-2:qianwei1:='分';
-1:qianwei1:='角';
0 :qianwei1:='元';
1 :qianwei1:='拾';
2 :qianwei1:='佰';
3 :qianwei1:='千';
4 :qianwei1:='萬';
5 :qianwei1:='拾';
6 :qianwei1:='佰';
7 :qianwei1:='千';
8 :qianwei1:='億';
9 :qianwei1:='十';
10:qianwei1:='佰';
11:qianwei1:='千';
end;
inc(qianwei);
if Small<0 then
BigMonth :='負'+wei1+qianwei1+BigMonth {組合成大寫金額}
else
BigMonth :=wei1+qianwei1+BigMonth {組合成大寫金額}
end;
end;
Result:=BigMonth;
end;
//利用系統時間產生隨機數
function Myrandom(Num: Integer): integer;
var
T: _SystemTime;
X: integer;
I: integer;
begin
Result := 0;
If Num = 0 then Exit;;
GetSystemTime(T);
X := Trunc(T.wMilliseconds/10) * T.wSecond * 1231;
X := X + random(1);
if X<>0 then
X := -X;
X := Random(X);
X := X mod num;
for I := 0 to X do
X := Random(Num);
Result := X;
end;
//打開輸入法
procedure OpenIME(ImeName: string);
var
i: integer;
MyHKL: hkl;
begin
if ImeName <> '' then begin
if Screen.Imes.Count <> 0 then begin
i := Screen.Imes.IndexOf(ImeName);
if i >= 0 then MyHKL := hkl(Screen.Imes.Objects[i]);
ActivateKeyboardLayout(MyHKL, KLF_ACTIVATE);
end;
end;
end;
//關閉輸入法
procedure CloseIME;
var
MyHKL: hkl;
begin
MyHKL := GetKeyboardLayout(0);
if ImmIsIme(MyHKL) then
ImmSimulateHotKey(Application.Handle, IME_CHOTKEY_IME_NONIME_TOGGLE);
end;
//打開中文輸入法
procedure ToChinese(hWindows: THandle; bChinese: boolean);
begin
if ImmIsIME(GetKeyboardLayOut(0)) <> bChinese then
ImmSimulateHotKey(hWindows, IME_THotKey_IME_NonIME_Toggle);
end;
//數據備份
procedure BackUpData(LpBackDispMessTitle:String);
var
i,j:integer;
Source,Dest:array[0..200]of char;
s1:string;
Lp:_SHFILEOPSTRUCTA;
Success:Integer;
begin
if MessageBox(Application.Handle,' 您確認要備份數據嗎？','詢問窗口',4+32+256)=6 then
begin
with LP do
begin
Lp.wnd:=Application.Handle;
wFunc:=FO_COPY;
s1:='DATA/*.*';
i:=Length(s1);
StrCopy(Source,PChar(s1));
Source[i]:=#0;
Source[i+1]:=#0;
Source[i+2]:=#0;
pFrom:=Source;
s1:='BACKUP';
j:=Length(s1);
StrCopy(Dest,PChar(s1));
Dest[j]:='/';
Dest[j+1]:=#0;
Dest[j+2]:=#0;
Dest[j+3]:=#0;
pTo:=Dest;
fFlags:=FOF_ALLOWUNDO;
fAnyOperationsAborted:=False;
lpszProgressTitle:=PChar(LpBackDispMessTitle);
end;
Success:=SHFileOperation(LP);
case Success of
0:
MessageBox(Application.Handle,' 所有數據已備份完成 ！','提示窗口',0+48);
117:
MessageBox(Application.Handle,Pchar(' 您未創建“'+ExtractFilePath(Application.ExeName)+'BACKUP”目錄所以不能完成數據備份 ！'),'提示窗口',0+16)
else
MessageBox(Application.Handle,' 在備份數據的過程中被用戶中途中斷 ！','提示窗口',0+16);
end;
end;
end;
////////////////////////////////////////////////////////////////////////////////
// //
// 從文件中讀取Ado連接字串 //
// //
////////////////////////////////////////////////////////////////////////////////
function GetConnectionString(DataBaseName:string):string;
var FileStringList:Tstringlist;
TempString: ansistring;
TheReg:TRegistry;KeyName,fAppPath:string;
i:Integer;
begin
TheReg:=TRegistry.Create;
try
TheReg.RootKey:=HKEY_LOCAL_MACHINE;
KeyName:='Software/政府採購管理系統';
if TheReg.OpenKey(KeyName,False) then
fAppPath:=TheReg.ReadString('ApplicationPath');
finally
TheReg.Free;
end;
FileStringList:=Tstringlist.Create;
//先判斷connection.txt是否存在,存在就調入
if FileExists(fAppPath+'/connection.txt') then
FileStringList.LoadFromFile(fAppPath+'/connection.txt')
else
begin
application.MessageBox('在系統所在目錄中沒有檢測到連接文件(connection.txt)，無法啓動系統。','提示',MB_IconError+mb_ok);
Result:='';
FileStringList.Free;
Exit;
end;
//組成一個符串，好進行處理。
TempString:='';
for i:=0 to FileStringList.Count-1 do
begin
TempString:=TempString+FileStringList.strings[i];
end;
{連接指定名稱的數據庫}
TempString:=Replace(TempString,'DataBaseName',DataBaseName,False);
Result:=TempString;
end;
{------------------------------------------------------------------------------}
{function GetRemoteServerName：返回遠程服務器的機器名稱}
function GetRemoteServerName:string;
var iniServer:TIniFile;
TheReg:TRegistry;KeyName,fAppPath,RServerName:string;
begin
TheReg:=TRegistry.Create;
try
TheReg.RootKey:=HKEY_LOCAL_MACHINE;
KeyName:='Software/政府採購管理系統';
if TheReg.OpenKey(KeyName,False) then
fAppPath:=TheReg.ReadString('ApplicationPath');
finally
TheReg.Free;
end;
{創建遠程服務器名稱}
try
iniServer:=TIniFile.Create(fAppPath+'/RemoteServerName.ini');
with iniServer do
RServerName:=ReadString('Option','RServerName','');
iniServer.Free;
except
raise exception.Create('致命錯誤：未找到包含Com服務器配置的信息文件，初始化失敗。');
end;
Result:=RServerName;
end;
initialization
WndLong := GetWindowLong(Application.Handle, GWL_EXSTYLE);
end.