func_this.prg

一个数据库管理系统

Define CLASS HeapForGetDir2 AS Custom
	Protected inAllocs, iaAllocs[1]
	inAllocs = 0
	iaAllocs = 0
	Name = "heap"
	Function CopyToHeap (lcInStr)
		Declare integer lstrcpyn in win32api as RtlCopytoMem integer lnDestBuffer, string @lpSource, integer nLength
		Declare integer GlobalAlloc in win32api integer wFlags, integer dwBytes
		Declare integer GlobalSize in win32api integer hMem
		Hmem = GlobalAlloc(0, len(lcInStr))         && 创建内存块
		lncb = GlobalSize ( hMem )                  && 获得内存块大小
		nPtr = RtlCopytoMem( hMem, lcInStr, lncb )  && 写入内存块内容
		With this
			If nPtr # 0
				.inAllocs = .inAllocs + 1
				Dimension .iaAllocs[.inAllocs]
				.iaAllocs[.inAllocs,1] = nPtr       && 内存地址
			Endif
		Endwith
		Return nPtr
	Endfunc
	Function CopyFromHeap (lnHmem)
		Declare integer lstrcpyn in win32api as RtlCopyfromMem string @lpDestString, integer lpSource, integer nLength
		Declare integer GlobalSize in win32api integer hMem
		lncb = GlobalSize ( lnHmem )                && 获得内存块大小
		lpDestString = repl(chr(0),lncb)
		= RtlCopyfromMem( @lpDestString, lnHmem, lncb)
		lcOutString = chrtranc( lpDestString, chr(0), "")
		Return lcOutString
	Endfunc
	Procedure Destroy
		Declare integer GlobalFree in win32api integer hMem
		With this
			For nCtr = 1 to .inAllocs
              =GlobalFree (.iaAllocs[nCtr])       && 释放内存块
			Endfor
		Endwith
	Endproc
Enddefine
*-------------END

FUNCTION Num2Long
LPARAMETER TNNUM
Declare RtlMoveMemory IN WIN32API AS RtlCopyLong STRING @pDestString,INTEGER @pVoidSource,INTEGER nLength
Local CSTRING
CSTRING = SPACE(4)
=RtlCopyLong(@CSTRING, BITOR(TNNUM,0), 4)
RETURN CSTRING
*-------END----------------

PROCEDURE Record_Err_Mess
LPARAMETERS lpLnots
*-- lpLnots  .T.  不提示错误   .F.  提示错误
IF AERROR(lcAerr)>0 &&错误信息放数组
   LOCAL lcCmess
   DO CASE
      CASE lcAerr[1,1]=108
        lcCmess="文件正在被其他用户使用！"
      CASE lcAerr[1,1]=109
        lcCmess="记录正在被其他用户使用！"
      CASE lcAerr[1,1]=1526  &&ODBC错误
        LOCAL lcNoccur,lcNcurr
        lcCmess=SYS(2018) &&错误信息
        lcNoccur=OCCURS("{##}",lcCmess) &&起止符{##}个数
        IF lcNoccur>=2 &&有#.....#段信息，解析
           lcNcurr=1 &&默认为第1段
           IF lcNoccur>2 &&有多段，则根据信息中的关键字确定取哪一段
              DO CASE
                 CASE "语句与 COLUMN REFERENCE 约束"$lcCmess AND "冲突"$lcCmess
                   lcNcurr=1
                 CASE "语句与 COLUMN FOREIGN KEY 约束"$lcCmess AND "冲突"$lcCmess
                   lcNcurr=2
              ENDCASE
           ENDIF
           lcCmess=STREXTRACT(lcCmess,"{##}","{##}",lcNcurr) &&取段信息
         ELSE &&没有#.....#段标记，去掉
           lcCmess=SUBSTR(lcCmess,AT("[SQL SERVER]",lcCmess)+LEN("[SQL SERVER]"))
           DO CASE
              CASE "无法将 NULL 值"$lcCmess AND "该列不允许空值"$lcCmess
                lcCmess="请指定"+STREXTRACT(lcCmess,"列 '","'")+"！"
              CASE "CREATE RULE 语句所强制的规则冲突"$lcCmess
                lcCmess="字段："+STREXTRACT(lcCmess,"列 '","'")+" 数据无效！"
              CASE "语句与 COLUMN CHECK 约束"$lcCmess AND "冲突"$lcCmess
                lcCmess="字段："+STREXTRACT(lcCmess,"COLUMN '","'")+" 数据无效！"
              CASE "导致 DATETIME 值越界"$lcCmess
                lcCmess="指定的日期无效！"
           ENDCASE
        ENDIF
      CASE lcAerr[1,1]=1539 &&触发器失败
        lcCmess=ICASE(lcAerr[1,5]=1,"新增记录失败！请检查数据是否正确！",lcAerr[1,5]=2,"更新记录失败！请检查数据是否正在使用或不允许更新！",lcAerr[1,5]=3,"删除记录失败！请检查数据是否正在使用或不允许删除！","操作失败！")
      CASE lcAerr[1,1]=1582 &&字段有效性规则被破坏
        lcCmess=lcAerr[1,2]
      CASE lcAerr[1,1]=1583 &&记录有效性规则被破坏
        lcCmess=lcAerr[1,2]
      CASE lcAerr[1,1]=1585 &&更新冲突
        lcCmess=lcAerr[1,2]
      CASE lcAerr[1,1]=1884 &&索引（名称）唯一性被破坏
        lcCmess=lcAerr[1,3]+"不允许重复！"
      OTHERWISE &&其它错误
        lcCmess=lcAerr[1,2]
   ENDCASE
   IF !lpLnots
      MESSAGEBOX(lcCmess,0+16,"提示")
   ENDIF
   RETURN lcCmess
ENDIF
*-------------END

PROCEDURE SaveAlias &&保存旧区
TRY
  _screen.N_OldAlias=SELECT(0)
CATCH
  _screen.AddProperty("N_OldAlias",SELECT(0))
ENDTRY
*-------------END

PROCEDURE RestoreAlias &&还原区
SELECT (_screen.N_OldAlias)
*-------------END

PROCEDURE Set_Cursor_Updatable
LPARAMETERS lpCcur,lpCkeyfield,lpCupdateField,lpCtable,lpCupdatelist,lpCwheretype
* lpCcur            临时表名 不指定默认当前表
* lpCkeyfield       临时表主键字段    （如多个基表都要更新，则应把对应的临时表主键都要写上，如："titleID,CustomID"）
*                        不指定，默认主键字段为字段一
* lpCupdateField    临时表可更新字段  （逗号分割的列表）
*                        不指定，默认可更新全部字段
* lpCtable          数据库基表        （如多个表，用逗号分割，如："table1,table2"）
*                        不指定，默认基表为同名临时表名
* lpCupdatelist     临时字段与基表字段对应关系 （格式 "临时表字段1 基表1.字段1,临时表字段2 基表2.字段1,....n" ）
*                        不指定，默认字段对应关系为临时表同名字段对应基表同名字段
* lpCwheretype      更新方式 (1、KEY 2、KEYANDUPDATABLE 3、KEYANDMODIFIED 4、KEYANDTIMESTAMP)
*                        不指定默认 KEY
LOCAL lcNjj,lcCls,lcNi,lcClsfld,lcNwhereType
IF VARTYPE(lpCcur)<>"C" OR EMPTY(lpCcur) &&默认当前别名
   lpCcur=ALIAS()
ENDIF
IF VARTYPE(lpCkeyfield)<>"C" OR EMPTY(lpCkeyfield) &&没指定主键，则为字段一
   lpCkeyfield=FIELD(1,lpCcur)
ENDIF
IF VARTYPE(lpCupdateField)<>"C" OR INLIST(ALLTRIM(lpCupdateField),"","*") &&生成可更新字段列表
   lpCupdateField=""
   FOR lcNjj=1 TO FCOUNT(lpCcur) &&字段循环
     lpCupdateField=lpCupdateField+","+FIELD(lcNjj,lpCcur)
   ENDFOR
   IF !EMPTY(lpCupdateField) &&去掉首，
      lpCupdateField=SUBSTR(lpCupdateField,2)
   ENDIF
ENDIF
IF VARTYPE(lpCtable)<>"C" OR EMPTY(lpCtable) &&默认基表同临时表
   lpCtable=lpCcur
ENDIF
IF AT(" ",lpCtable)<>0 &&如果基表名有空格,则用[]括起来
   lpCtable="["+lpCtable+"]"
ENDIF
IF VARTYPE(lpCupdatelist)<>"C" OR EMPTY(lpCupdatelist) &&没指定UpdateNameList，循环处理
   lpCupdatelist=""
   lcCls=","+lpCupdateField+","
   lcNjj=OCCURS(",",lcCls)-1 &&字段个数
   FOR lcNi=1 TO lcNjj
     lcClsfld=ALLTRIM(STREXTRACT(lcCls,",",",",lcNi))
     lpCupdatelist=lpCupdatelist+","+lcClsfld+" "+lpCtable+"."+lcClsfld
   ENDFOR
   IF !EMPTY(lpCupdatelist) &&去掉首，
      lpCupdatelist=SUBSTR(lpCupdatelist,2)
   ENDIF
ENDIF
IF VARTYPE(lpCwheretype)<>"C" OR EMPTY(lpCwheretype) &&处理wheretype,默认Key
   lpCwheretype="KEY"
ENDIF
lpCwheretype=UPPER(lpCwheretype)
DIMENSION a_where(4)
a_where(1)="KEY"
a_where(2)="KEYANDUPDATABLE"
a_where(3)="KEYANDMODIFIED"
a_where(4)="KEYANDTIMESTAMP"
lcNwhereType=ASCAN(a_where,lpCwheretype)
IF lcNwhereType=0
   MESSAGEBOX("参数lpCwheretype传递的值错误！",0+16,"提示")
   RETURN .F.
ENDIF
CURSORSETPROP("Tables",lpCtable,lpCcur)
CURSORSETPROP("KeyFieldList",lpCkeyfield,lpCcur)
CURSORSETPROP("UpdatableFieldList",lpCupdateField,lpCcur)
CURSORSETPROP("UpdateNameList",lpCupdatelist,lpCcur)
CURSORSETPROP("WhereType",lcNwhereType,lpCcur)
CURSORSETPROP("SendUpdates",.T.,lpCcur)
RETURN .T.
* ----  END

FUNCTION IsSelAccset
LPARAMETERS lpNotMess
*  lpNotMess  没有选择数据库时  .T.  不提示  .F. 提示
IF !lpNotMess AND EOF("accset")
   MESSAGEBOX("请先选择数据库！",0+16,"提示")
ENDIF
RETURN !EOF("accset")
* ----  END

FUNCTION HavePower
LPARAMETERS lpCop,lpCpow,lpNomess
*--  lpCop    操作员编码;
     lpCpow   权限列;
     lpNomess 无权限时 .T. 不提示 .F. 提示
LOCAL lcLqx
lcLqx=.F.
IF RTRIM(dboper.opid)<>_Screen.c_operid
   SaveAlias()
   SELECT dboper
   LOCATE FOR opid=_Screen.c_operid
   RestoreAlias()
ENDIF
lcLqx=!EOF("dboper") AND EVALUATE("dboper."+lpCpow)
IF !lcLqx AND !lpNomess
   MESSAGEBOX("没有操作权限！",0+16,"提示")
ENDIF
RETURN lcLqx
* ----  END

FUNCTION IsSqldbused
LPARAMETERS lpCdb
*--  lpCdb   Sql数据库
SaveAlias()
SQLEXEC(_Screen.n_conn_pub,"select count(*) as fldcnt from master..sysprocesses where dbid=db_id('"+lpCdb+"')","CurTemp5371")
lcNcnt=CurTemp5371.fldcnt
USE
RestoreAlias()
RETURN lcNcnt>0
* ----  END

FUNCTION TestConnDB
LPARAMETERS lpLok,lpLno,lpLts,lpLbl
*--  lpLok   测试连接成功  .T. 提示 .F. 不提示 ;
     lpLno   测试连接失败  .T. 提示 .F. 不提示 ;
     lpLts   =.T. 提示窗口  =.F. 无提示窗口 ;
     lpLbl   =.T. 保持连接句柄 =.F. 断开连接句柄
*--没有选择数据库返回
IF !IsSelAccset()
   RETURN .F.
ENDIF
LOCAL lcCdb,lcCerr,lcCon
lcCdb=ALLTRIM(accset.AccsetID)
*--测试连接
IF lpLts
   ShowWaiting("正在连接数据库"+lcCdb+"...",,_Screen.c_giffile)
ENDIF
lcCon="Driver=SQL Server;Server="+_Screen.ljServer+IIF(!EMPTY(_Screen.ljPort),","+_Screen.ljPort,"")+";DataBase="+lcCdb+";Uid="+_Screen.ljUid+";Pwd="+_Screen.ljPwd+";NetWork=DBMSSOCN"
_Screen.n_conn_pub2=SQLSTRINGCONNECT(lcCon)
IF _Screen.n_conn_pub2>0
   IF !lpLbl
      =SQLDISCONNECT(_Screen.n_conn_pub2)
   ENDIF
   IF lpLts
      ClearWaiting()
   ENDIF
   IF lpLok
      MESSAGEBOX("测试连接数据库"+lcCdb+"成功！",0+64,"提示")
   ENDIF
   RETURN .T.
 ELSE
   lcCerr=Record_Err_Mess(.T.)
   IF lpLts
      ClearWaiting()
   ENDIF
   IF lpLno
      MESSAGEBOX("测试连接数据库"+lcCdb+"失败！"+CHR(13)+"错误信息："+CHR(13)+lcCerr,0+16,"提示")
   ENDIF
   RETURN .F.
ENDIF
*---------------END

FUNCTION SQLConnStr
LPARAMETERS lpCserver,lpCport,lpCdb,lpCuid,lpCpwd
lpCserver=IIF(VARTYPE(lpCserver)="C",lpCserver,"")
lpCport=IIF(VARTYPE(lpCport)="C",lpCport,"")
lpCdb=IIF(VARTYPE(lpCdb)="C",lpCdb,"")
lpCuid=IIF(VARTYPE(lpCuid)="C",lpCuid,"")
lpCpwd=IIF(VARTYPE(lpCpwd)="C",lpCpwd,"")
LOCAL lcCconstr2
TEXT TO lcCconstr2 TEXTMERGE NOSHOW
Driver=SQL Server;Server=<<lpCserver>><<IIF(!EMPTY(lpCport),","+lpCport,"")>>;DataBase=<<lpCdb>>;Uid=<<lpCuid>>;Pwd=<<lpCpwd>>;NetWork=DBMSSOCN
ENDTEXT
RETURN lcCconstr2
* ----  END

PROCEDURE Ref_MainGrid
P_FRMMAIN.grid1.Refresh
P_FRMMAIN.grid1.Setfocus
ENDPROC
* ----  END

PROCEDURE List_DelALL
*--判断权限
IF !HavePower(_Screen.c_operid,"list_dele")
   RETURN .F.
ENDIF
*--清除数据库列表
IF MESSAGEBOX("确认清除数据库列表吗？",4+16+256,"询问")=7
   RETURN .F.
ENDIF
BEGIN TRANSACTION 
DELETE ALL IN "accset"
IF TABLEUPDATE(1,.T.,"accset")
   END TRANSACTION
   Ref_MainGrid()
   MESSAGEBOX("清除数据库列表成功！",0+64,"提示")
  ELSE
   ROLLBACK
   MESSAGEBOX("清除数据库列表出错！",0+16,"提示")
ENDIF
RETURN .T.
ENDPROC
* ----  END