m.lcFile_S = 'D:\Temp\Source.jpg'
m.lcFile_T = 'D:\Temp\Target.jpg'

m.lnW_T = 160       && 目标图宽、高度
m.lnH_T = 240
m.lnXDpi_T = 72     && 目标图分辨率
m.lnYDpi_T = 72

Set Classlib To "_GDIPlus.Vcx" Additive

oGraphics=CreateObject("gpGraphics")      && 创建工作图像

oImage=CreateObject("gpImage")            && 源图
oImage.CreateFromFile(m.lcFile_S)         && 从源图创建
m.lnW = oImage.ImageWidth                 && 宽
m.lnH = oImage.ImageHeight                && 高
m.lnXDpi = oImage.HorizontalResolution    && 水平分辨率
m.lnYDpi = oImage.VerticalResolution      && 垂直分辨率

oBitMap=CreateObject("gpBitMap")          && 目标图
oBitMap.Create(m.lnW_T, m.lnH_T)          && 按目标图大小创建

oGraphics.CreateFromImage(oBitMap)               && 工作图像按目标图建立
oBitMap.SetResolution(m.lnXDpi_T, m.lnYDpi_T)    && 设置目标图分辨率

oGraphics.DrawImageScaled(oImage, 0, 0, m.lnW_T, m.lnH_T)    && 源图按指定矩形区域缩放

m.lnQuality = 90  && 100                  && 图片保存质量
oBitMap.SaveToFile(m.lcFile_T, oImage.GetEncoderCLSID("image/jpeg"), "quality="+Transform(m.lnQuality))    && 按源文件类型保存至目标文件

Release oBitMap    && 释放
Release oImage
Release oGraphics

Release Classlib _GdiPlus

“Provider=Microsoft.Jet.OLEDB.4.0;Data Source=”&Server.mappath(db)

“driver=Microsoft Access Driver (*.mdb);DBQ=”&Server.MapPath(db)

既然这样，就只能使用一个办法，将IIS的运行环境设置为32位：

IIS6上的做法:

1.命令行键入:

cscript.exe %SYSTEMDRIVE%\inetpub\adminscripts\adsutil.vbs SET W3SVC/AppPools/Enable32bitAppOnWin64 1

即设置IIS6允许32位程序运行在64位机器上

2.重新注册.net FrameWorks

%SYSTEMROOT%\Microsoft.NET\Framework\v2.0.50727\aspnet_regiis.exe -i

3.完成之后，应该会看到多出一个32位的asp.net,如下图:

将其设置为允许，缺点：这样会使整个IIS上的所有站点都以32位兼容方式运行

       然后再运行一下：%SYSTEMROOT%\Microsoft.NET\Framework\v2.0.50727\aspnet_regiis.exe -i

      这样就可以跑32位的程序了。

不过在IIS7上的做法要简单很多：

应用程序池，高级设置–>允许32位应用程序，如下图:

*--定义：一般放到主程序或表单(集)的Load事件中
Public WM_CAP_DRIVER_DISCONNECT
Public hwndc,WM_CAP_SAVEDIB,WM_CAP_FILE_SET_CAPTURE_FILEA,WM_CAP_SEQUENCE,WM_CAP_STOP
Declare Integer capCreateCaptureWindowA In "AVICAP32.DLL" String lpszWindowName ,Integer dwStyle ,;
    Integer x, Integer Y, Integer nWidth ,Integer nHeight,Integer ParentWin,Integer nId
Declare Integer SendMessage In "user32" Integer HWnd, Integer wmsg,Integer wpar1, Integer wpar2
Declare Integer SendMessage In "user32" As SendMessageA Integer HWnd, Integer wmsg,Integer wpar1, String wpar2
 

*--显示：可以放到按钮或表单(集)的Init事件中
WM_USER = 1024
WM_CAP_START = WM_USER
WM_CAP_STOP = WM_CAP_START + 68
WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10
WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11
WM_CAP_SAVEDIB = WM_CAP_START + 25
WM_CAP_GRAB_FRAME = WM_CAP_START + 60
WM_CAP_SEQUENCE = WM_CAP_START + 62
WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20
WM_CAP_SEQUENCE_NOFILE =WM_CAP_START+ 63
WM_CAP_SET_OVERLAY =WM_CAP_START+ 51
WM_CAP_SET_PREVIEW =WM_CAP_START+ 50
WM_CAP_SET_CALLBACK_VIDEOSTREAM = WM_CAP_START +6
WM_CAP_SET_CALLBACK_ERROR=WM_CAP_START +2
WM_CAP_SET_CALLBACK_STATUSA= WM_CAP_START +3
WM_CAP_SET_CALLBACK_FRAME= WM_CAP_START +5
WM_CAP_SET_SCALE=WM_CAP_START+ 53
WM_CAP_SET_PREVIEWRATE=WM_CAP_START+ 52
*第3、4个参数是定义显示位置,第5、6个参数是定义显示大小。
hWndC = capCreateCaptureWindowA('My Own Capture Window',1342177280,0,0,320,240,Thisform.HWnd ,0)
If hWndC <> 0
    SendMessage(hWndC, WM_CAP_SET_CALLBACK_VIDEOSTREAM, 0, 0)
    SendMessage(hWndC, WM_CAP_SET_CALLBACK_ERROR, 0, 0)
    SendMessage(hWndC, WM_CAP_SET_CALLBACK_STATUSA, 0, 0)
    SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0)
    SendMessage(hWndC, WM_CAP_SET_SCALE, 1, 0)
    SendMessage(hWndC, WM_CAP_SET_PREVIEWRATE, 66, 0)
    SendMessage(hWndC, WM_CAP_SET_OVERLAY, 1, 0)
    SendMessage(hWndC, WM_CAP_SET_PREVIEW, 1, 0)
    * THISFORM.ACTIVATE
Endif
 

*--关闭显示：
SendMessage(hWndC,WM_CAP_DRIVER_DISCONNECT, 0, 0)
hWndC=0
 

*--保存图像：
*--无法控制生成的文件尺寸，因为是由摄像头本身默认的，不过可用Image控件显示时进行等比缩小的。
ss=Getfile("bmp;Jpg")
If !Empty(ss)
    SendMessageA(hWndC,WM_CAP_SAVEDIB,0,SS)
Endif
 

*--录像：
ss = Getfile("avi")
If !Empty(ss)
    SendMessageA(hWndC,WM_CAP_FILE_SET_CAPTURE_FILEA,0,ss)
    SendMessageA(hWndC, WM_CAP_SEQUENCE, 0, 0)
    This.Enabled=.F.
    Thisform.MousePointer= 0
    Thisform.停止录像按钮.Enabled=.T.
Endif
 

*--停止录像：
SendMessage(hWndC, WM_CAP_STOP, 0, 0)
Thisform.开始录像按钮.Enabled=.T.
This.Enabled=.F.

SET CLASSLIB TO HOME(1) + "FFC\_gdiplus.vcx"
loColorA = CREATEOBJECT("gpColor",255,0,0,255)          &&红色：颜色值为红，绿，蓝，透明度（0为透明，255为不透明）
loColorB = CREATEOBJECT("gpColor",50,50,50,255)         &&深灰色：颜色值为红，绿，蓝，透明度（0为透明，255为不透明）
loPen = CREATEOBJECT("gpPen",loColorB,2)                &&用前句创建的画笔颜色，画笔宽度为2个像素，可自行更改。
loSolidBrush = CREATEOBJECT("gpSolidbrush",loColorA)    &&创建实体画笔，就要用于写文字和填充。
lopoint = CREATEOBJECT("gpPoint",50,50)                 &&创建点对象
loRectangle = CREATEOBJECT("gprectangle",50,50,300,300) &&创建矩形对象
loGraphics = CREATEOBJECT("gpGraphics")                 &&创建画布对象
loGraphics.createfromHwnd(Thisform.HWnd)                  &&将本画布对象设定为表单大小，这是固定写法。后面我会讲自定义画布大小
loColorA.set(255,0,0,255)
loSolidBrush.create(locolorA)
lographics.FillPie(loSolidBrush,loRectangle,45,90)        &&绘制实心扇形图。下同

loColorA.set(0,255,0,255)
loSolidBrush.create(locolorA)
lographics.FillPie(loSolidBrush,loRectangle,135,90)

loColorA.set(0,0,255,255)
loSolidBrush.create(locolorA)
lographics.FillPie(loSolidBrush,loRectangle,225,90)

loColorA.set(110,16,172,255)
loSolidBrush.create(locolorA)
lographics.FillPie(loSolidBrush,loRectangle,315,90)

loGraphics.Drawrectangle(loPen,50,50,300,300)             &&绘制矩形
loGraphics.DrawLine(loPen,50,50,350,350)                  &&绘制直线
loGraphics.Drawline(loPen,350,50,50,350)
lographics.DrawEllipse(lopen,50,50,300,300)               &&绘制椭圆

以上程序段你可以放在表单的Pait()事件里，当然也可以放在其它的Click事件里。
运行，看看效果吧。不过我们要将它保存为图片，这里我们得做必要的修改。如下：
不过这次我是把代码写在了表单的Activate事件里了：

SET CLASSLIB TO HOME(1) + "FFC\_gdiplus.vcx"
Thisform.AddObject("ShowDrawing","Image")
loColorA = CREATEOBJECT("gpColor",255,255,255,255)      &&红色：颜色值为红，绿，蓝，透明度（0为透明，255为不透明）
loColorB = CREATEOBJECT("gpColor",50,50,50,255)         &&深灰色：颜色值为红，绿，蓝，透明度（0为透明，255为不透明）

lobitmap = CREATEOBJECT("gpBitmap",Thisform.Width,Thisform.Height)

loPen = CREATEOBJECT("gpPen",loColorA,2)                &&用前句创建的画笔颜色，画笔宽度为2个像素，可自行更改。
loBrush = CREATEOBJECT("gpSolidbrush",loColorA)

loSolidBrush = CREATEOBJECT("gpSolidbrush",loColorA)    &&创建实体画笔，就要用于写文字和填充。
lopoint = CREATEOBJECT("gpPoint",50,50)                 &&创建点对象
loRectangle = CREATEOBJECT("gprectangle",50,50,300,300) &&创建矩形对象
loGraphics = CREATEOBJECT("gpGraphics")                 &&创建画布对象

*loGraphics.createfromHwnd(Thisform.HWnd)                 &&将本画布对象设定为表单大小，这是固定写法。后面我会讲自定义画布大小
loGraphics.createfromImage(lobitmap)
loGraphics.fillRectangle(loBrush,0,0,Thisform.Width,Thisform.Height)

loColorA.set(255,0,0,255)
loSolidBrush.create(locolorA)
lographics.FillPie(loSolidBrush,loRectangle,45,90)        &&绘制实心扇形图。下同

loColorA.set(0,255,0,255)
loSolidBrush.create(locolorA)
lographics.FillPie(loSolidBrush,loRectangle,135,90)

loColorA.set(0,0,255,255)
loSolidBrush.create(locolorA)
lographics.FillPie(loSolidBrush,loRectangle,225,90)

loColorA.set(110,16,172,255)
loSolidBrush.create(locolorA)
lographics.FillPie(loSolidBrush,loRectangle,315,90)

loGraphics.Drawrectangle(loPen,50,50,300,300)             &&绘制矩形
loGraphics.DrawLine(loPen,50,50,350,350)                  &&绘制直线
loGraphics.Drawline(loPen,350,50,50,350)
lographics.DrawEllipse(lopen,50,50,300,300)               &&绘制椭圆

lSuccess = loBitmap.Savetofile("D:\test.jpg", "image/jpeg", "quality=100" )

IF lSuccess
   Thisform.ShowDrawing.Picture = "D:\test.jpg"
   Thisform.ShowDrawing.left = 0
   Thisform.ShowDrawing.Top = 0
   Thisform.ShowDrawing.Visible = .T.
   WAIT WINDOW "图片已经保存到：D:\test.jpg" NOWAIT
ELSE
   MESSAGEBOX("图片保存失败")
ENDIF

[Taskbar]
Command=ToggleDesktop

保存文件后将其拉入快速启动栏即可。

资源管理的恢复类似，其文件内容为：
[Shell]
Command=2
IconFile=explorer.exe,1

[Taskbar]
Command=Explorer

    从古至今，中国几千年来，从来没有失去过一些传统的礼仪。就在当代，我们仍然在各种应酬、集会、社交活动之中，保留着这些礼仪形式。而这些礼仪，主要就是拱手礼、握手礼和鞠躬礼。

--返回本地服务器中定义的链接服务器列表
Exec sp_linkedservers
--返回表的字段中，其中对MSSQL而言：SRV_NAME(链接服务器的名称)，SRV_DATASOURCE(与指定链接服务器对应的服务器名)

--访问表时以四部分名称形式
--查询示例
Select * From MyLinkServer.数据库名.dbo.表名

--导入示例
Select * Into 表 From MyLinkServer.数据库名.dbo.表名

--以后不再使用时删除链接服务器
Exec sp_dropserver 'MyLinkServer','droplogins'   --以用户名登录时
--或：
Exec sp_dropserver 'MyLinkServer'   --未以用户名登录时

--连接远程/局域网数据(OpenRowSet/OpenQuery/OpenDataSource)
--1、OpenRowSet
--查询示例
Select * From OpenRowSet('SQLOLEDB','SQL服务器名';'用户名';'密码',数据库名.dbo.表名)
--生成本地表
Select * Into 表 From OpenRowSet('SQLOLEDB','SQL服务器名';'用户名';'密码',数据库名.dbo.表名)
--把本地表导入远程表
Insert OpenRowSet('SQLOLEDB','SQL服务器名';'用户名';'密码',数据库名.dbo.表名)
Select *From 本地表
--更新本地表
Update b
Set b.列A=a.列A
From OpenRowSet('SQLOLEDB','SQL服务器名';'用户名';'密码',数据库名.dbo.表名) As a Inner Join 本地表 b
On a.column1=b.column1

--OpenQuery用法需要创建一个连接
--首先创建一个连接创建链接服务器
Exec sp_addlinkedserver 'MyLinkServer','','SQLOLEDB','远程服务器名或IP'
--查询
Select * From OpenQuery(MyLinkServer,'Select * From 数据库.dbo.表名')
--把本地表导入远程表
Insert OpenQuery(MyLinkServer,'Select * From 数据库.dbo.表名')
Select * From 本地表
--更新本地表
Update b
Set b.列B=a.列B
From OpenQuery(MyLinkServer,'Select * From 数据库.dbo.表名') As a
Inner Join 本地表 b On a.列A=b.列A

--3、OpenDataSource
Select * From OpenDataSource('SQLOLEDB','Data Source=远程服务器名或IP;User ID=登陆名;Password=密码').test.dbo.roy_ta
--把本地表导入远程表
Insert OpenDataSource('SQLOLEDB','Data Source=远程服务器名或IP;User ID=登陆名;Password=密码').数据库.dbo.表名
Select * From 本地表

--第二部分(实际示例)
--OpenRowSet使用OLEDB的一些例子
Select * From OpenRowSet('SQLOLEDB','Server=(local);PWD=***;UID=sa;','Select * From TB.dbo.school') As t
Select * From OpenRowSet('SQLOLEDB','Server=(local);PWD=***;UID=sa;',TB.dbo.school) As t
Select * From OpenRowSet('SQLOLEDB','Server=(local);Trusted_Connection=yes;',TB.dbo.school) As t
Select * From OpenRowSet('SQLOLEDB','(local)';'sa';'***','Select * From TB.dbo.school') As t
Select * From OpenRowSet('SQLOLEDB','(local)';'sa';'***',TB.dbo.school) As t
Select * From OpenRowSet('SQLOLEDB','(local)';'sa';'***','Select school.id As id1,people.id As id2 From TB.dbo.school Inner Join TB.dbo.people On school.id=people.id') As t

--OpenRowSet使用SQLNCLI的一些例子(SQLNCLI在SqlServer2005以上才能使用)
Select * From OpenRowSet('SQLNCLI','(local)';'sa';'***','Select * From TB.dbo.school') As t
Select * From OpenRowSet('SQLNCLI','Server=(local);Trusted_Connection=yes;','Select * From TB.dbo.school') As t
Select * From OpenRowSet('SQLNCLI','Server=(local);UID=sa;PWD=***;','Select * From TB.dbo.school') As t
Select * From OpenRowSet('SQLNCLI','Server=(local);UID=sa;PWD=***;',TB.dbo.school) As t
Select * From OpenRowSet('SQLNCLI','Server=(local);UID=sa;PWD=***;DataBase=TB','Select * From dbo.school') As t

--OpenRowSet其他使用
Insert OpenRowSet('SQLNCLI','Server=(local);Trusted_Connection=yes;','Select name From TB.dbo.school Where id=1') Values('ghjkl') /*要不要Where都一样，插入一行*/
Update OpenRowSet('SQLNCLI','Server=(local);Trusted_Connection=yes;','Select name From TB.dbo.school Where id=1') Set name='kkkkkk'
Delete From OpenRowSet('SQLNCLI','Server=(local);Trusted_Connection=yes;','Select name From TB.dbo.school Where id=1')

--OpenDataSource使用SQLNCLI的一些例子
Select * From OpenDataSource('SQLNCLI','Server=(local);UID=sa;PWD=***;').TB.dbo.school As t
Select * From OpenDataSource('SQLNCLI','Server=(local);UID=sa;PWD=***;DataBase=TB').TB.dbo.school As t

--OpenDataSource使用OLEDB的例子
Select * From OpenDataSource('SQLOLEDB','Server=(local);Trusted_Connection=yes;').TB.dbo.school As t

--OpenDataSource其他使用
Insert OpenDataSource('SQLNCLI','Server=(local);Trusted_Connection=yes;').TB.dbo.school(name) Values('ghjkl') /*要不要Where都一样，插入一行*/
Update OpenDataSource('SQLNCLI','Server=(local);Trusted_Connection=yes;').TB.dbo.school Set name='kkkkkk'
Delete From OpenDataSource('SQLNCLI','Server=(local);Trusted_Connection=yes;').TB.dbo.school Where id=1

--OpenQuery使用OLEDB的一些例子
Exec sp_addlinkedserver 'MyLinkServer','','SQLOLEDB','(local)'
Exec sp_addlinkedsrvlogin 'MyLinkServer','false',null,'sa','***'
Select * From OpenQuery(MyLinkServer, 'Select *  From TB.dbo.school')

--OpenQuery使用SQLNCLI的一些例子
Exec sp_addlinkedserver 'MyLinkServerA','','SQLNCLI','(local)'
Exec sp_addlinkedsrvlogin 'MyLinkServerA','false',null,'sa','***'
Select * From OpenQuery(MyLinkServerA,'Select *  From TB.dbo.school')

--OpenQuery其他使用
Insert OpenQuery(MyLinkServerA,'Select name From TB.dbo.school Where id=1') Values('ghjkl')  /*要不要Where都一样，插入一行*/
Update OpenQuery(MyLinkServerA,'Select name From TB.dbo.school Where id=1') Set name='kkkkkk'
Delete OpenQuery(MyLinkServerA,'Select name From TB.dbo.school Where id=1')

cStr=GetSqlServer()
nCount=ALines(aServer,cStr,",")   &&切分生成数组
?
? "可连接的 SQL Server 服务器"+Transform(nCount)+"个,分别为："
For ii=1 to nCount
    ? ii,aServer[ii] &&将名字显示出来
EndFor
Set Library To

** 例二 ****************************************************
* Use SqlDMO.DLL, must install SQLServer or SqlDMO
loSqlDMO=Createobject("SQLDMO.Application")
loSvrs=loSqlDMO.ListAvailableSQLServers()
lnSvrsCount=loSvrs.Count
?
If lnSvrsCount=0
    ? "没有找到可用的 SQL Server 服务器。"
Else
    ? "可连接的 SQL Server 服务器"+Transform(lnSvrsCount)+"个,分别为："
    For ii=1 TO lnSvrsCount
        ? ii,loSvrs.Item(ii)
    Endfor
Endif
Release loSqlDMO

** 例三 *****************************************************
* Use Windows API, Only VFP9
#Define MAX_PREFERRED_LENGTH        -1
#Define SV_TYPE_SQLSERVER           0x00000004

Declare Long NetServerEnum In netapi32 string ServerName, Long nlevel, ;
        Long @ bufptr, Long prefmaxlen, long @ entriesread, ;
        Long @ totalentries, Long servertype, string domain, Long resume_handle
Declare Long NetApiBufferFree In netapi32 Long bufptr
Declare Long lstrlenW In win32api String @ lpString

If Version(5)<900
   =MessageBox( '需要 vfp 9.0 运行环境！', 16, '错误！' )
Else
   ?
   Store 0 To lnBuff, lnReadNums, lnTotNums
   If 0 == NetServerEnum( Null, 100, @ lnBuff, MAX_PREFERRED_LENGTH, @ lnReadNums, ;
                          @ lnTotNums, SV_TYPE_SQLSERVER, Null, 0) and lnReadNums > 0
      ? "可连接的 SQL Server 服务器"+TRANSFORM(lnReadNums)+"个,分别为："
      For ii = 1 To lnReadNums
          m.lnAddr = CToBin(Sys(2600, m.lnBuff + (m.ii-1)*8 + 4, 4), 'RS')
          m.lcSrv = Sys(2600, m.lnAddr, 256)
          ? ii,Left(Strconv(m.lcSrv, 6), lstrlenW(m.lcSrv))
      Endfor
   Else
      ? '没有找到可用的 SQL Server 实例。'
   Endif
   If lnBuff > 0
      NetApiBufferFree(lnBuff)
   Endif
Endif
CLEAR DLLS

** 例四 ***********************************************
** 为了与其他例子类似处理，将本例中的Cursor或Table除去了，同时代码也作了相应修改。特注明！
*-----------------------------------------------
* 函数: 获取局域网内所有SqlServer
* 设计: 红雨
* 时间: 2005.04.01
*-----------------------------------------------
?
? NetEnumSqlServer()

Function NetEnumSqlServer()
    Declare SHORT SQLBrowseConnect In odbc32 Integer ConnectionHandle, String InConnectionString, ;
            Integer StringLength1, String @ OutConnectionString, Integer BufferLength, Integer @ StringLength2Ptr
    Declare SHORT SQLAllocHandle In odbc32 Integer HandleType, Integer InputHandle, Integer @ OutputHandlePtr
    Declare SHORT SQLFreeHandle In odbc32 Integer HandleType, Integer Handle
    Declare SHORT SQLSetEnvAttr In odbc32 Integer EnvironmentHandle, Integer Attribute, ;
            Integer ValuePtr, Integer StringLength

    Local hEnv, hConn, cInString, cOutString, nLenOutString, nCnt, iCnt
    m.nCnt = 0
    m.hEnv = 0
    m.hConn = 0
    m.cInString = "DRIVER=SQL SERVER"
    m.cOutString = Space(2048)
    m.nLenOutString = 0
    Local Array aServerList[1]

    If SQLAllocHandle(1, 0, @hEnv) = 0
        If SQLSetEnvAttr(m.hEnv, 200, 3, 0) = 0
            If SQLAllocHandle(2, m.hEnv, @hConn) = 0
                If SQLBrowseConnect(m.hConn, @cInString, Len(m.cInString), @cOutString, 2048, @nLenOutString) = 99
                    m.nCnt = Alines(aServerList, Strextract(m.cOutString, '{', '}'), .T., ',')
                    lcMsg = '可连接的 SQL Server 服务器'+TRANSFORM(m.nCnt)+'个,分别为：' 
                    For m.iCnt = 1 To m.nCnt
                        lcMsg = lcMsg + Chr(13) + Chr(10) + Chr(9) + Transform(m.iCnt) + aServerList[iCnt]
                    Endfor
                Else
                    lcMsg = '没有找到可用的 SQL Server 实例。'
                Endif
            Endif
        Endif
    Endif
    Clear Dlls
    Return lcMsg
Endfunc
*************************************************

** 例五 ************************** 此例与红雨先生的上例近似，也取自网络并作部分修改
?
? GetNetSqlServerApi()

Function GetNetSqlServerApi()
* Use ODBC API
#Define SQL_HANDLE_ENV          1 
#Define SQL_HANDLE_DBC          2 
#Define SQL_NULL_HANDLE         0 
#Define SQL_SUCCESS         0 
#Define SQL_SUCCESS_WITH_INFO       1 
#Define SQL_NEED_DATA           99 
#Define SQL_ERROR           -1 
#Define SQL_INVALID_HANDLE      -2 
#Define SQL_ATTR_ODBC_VERSION       200 
#Define SQL_OV_ODBC3            3 
#Define SQL_NTS             -3 
#Define ENUM_SERVERS_MAX_RET_LENGTH -1  
 
lcDrvName = 'Driver={SQL Server}' 

Declare short SQLAllocHandle In odbc32 short HandleType, Long InputHandle, Long @ OutputHandlePtr
Declare short SQLSetEnvAttr In odbc32 long EnvironmentHandle, Long nAttribute, Long ValuePtr, Long StringLength
Declare short SQLBrowseConnect In odbc32 long ConnectionHandle, String InConnectionString, short StringLength1, ;
        String @ OutConnectionString, short BufferLength, short @ StringLength2Ptr
Declare short SQLDisconnect In odbc32 As _SQLDisconnect long ConnectionHandle
Declare short SQLFreeHandle In odbc32 long HandleType, Long Handle

* Allocate the environment handle  
hSQLEnv = 0
lnResult = SQLAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE, @ hSQLEnv)
If (lnResult == SQL_SUCCESS Or lnResult == SQL_SUCCESS_WITH_INFO)
    * Set the environment attribute to SQL_OV_ODBC3
    lnResult = SQLSetEnvAttr(hSQLEnv, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC3, 0)
    If (lnResult == SQL_SUCCESS Or lnResult == SQL_SUCCESS_WITH_INFO)
        * Allocate a connection handle
        hSQLHdbc = 0
        lnResult = SQLAllocHandle(SQL_HANDLE_DBC, hSQLEnv, @ hSQLHdbc)
        If (lnResult == SQL_SUCCESS Or lnResult == SQL_SUCCESS_WITH_INFO)
            szConnStrOut = SPACE(2048)
            lnLen = 0
            * Call SQLBrowseConnect for additional information  
            lnResult = SQLBrowseConnect(hSQLHdbc, lcDrvName, Len(m.lcDrvName), @ szConnStrOut, 2048, @ lnLen)
            If (lnResult == SQL_SUCCESS Or lnResult == SQL_NEED_DATA)
                 Return ListSqlServersList(Left(szConnStrOut, lnLen))
            Endif
            _SQLDisconnect(hSQLHdbc)  
        Endif  
        SQLFreeHandle(SQL_HANDLE_DBC, hSQLHdbc)  
    Endif  
Endif  
SQLFreeHandle(SQL_HANDLE_ENV, hSQLEnv)
Clear Dlls
Endfunc

Function ListSqlServersList(tcConnectString)  
    Local ii, lcSvrs, lcSvr, lcMsg, laSvrs[1]  
    m.nCnt = Alines(laSvrs, Strextract(tcConnectString, '{', '}'), .T., ',')
    If m.nCnt > 0
        lcMsg = '找到 '+TRANSFORM(m.nCnt)+'个 SQL Server 实例：'
        For m.ii = 1 To m.nCnt
            lcMsg = lcMsg + Chr(13) + Chr(10) + Chr(9) + Transform(m.ii) + laSvrs[m.ii]  
        Endfor  
    Else
        lcMsg = '没有找到可用的 SQL Server 实例。'
    Endif
    Return lcMsg
Endfunc

****************************** 控件注册函数
Function CheckCtrlFileRegist
Parameters lcCheck

&& 调用形如：CheckCtrlFileRegist("ctGrid.ctGridCtrl.3")
&& 其中，经常用到的控件如下：
&& MS日期控件 MSComCt2.OCX 版本2-("MSComCtl2.DTPicker.2")(MS Date and Time Picker Control 6.0 (SP4))
&& 视频头控件 AVCap.OCX 版本1-("AVCap.AVCapture.1")
&& DBI表格控件 ctGrid.OCX 版本3-("ctGrid.ctGridCtrl.3")，版本1-("ctGrid.ctGridCtrl.1")
&& DBI下拉框控件 ctCombo.OCX 版本2-("ctCoLorCombo.ctColorComboCtrl.2")
&& DBI工具条控件 ctToolBar.OCX 版本4-("ctToolBar.ctToolBarCtrl.4")
&& DBI树形控件 ctTree.OCX 版本7-("ctTree.ctTreeView.7")

Local oErr As Exception, oErrExit As Exception
Local lcCtrlFile As Character, lcCtrl As Character, lcRun As Character
Local oCtrl As Object, oShell As Object
Local lcMess As Character

lcMess=''
lcCtrl=SubStr(lcCheck,1,At('.',lcCheck,1)-1)

Try
  oCtrl=CreateObject(lcCheck)
Catch To oErr
  oErr.UserValue="发现OCX控件["+lcCtrl+"]未注册！"
  =MessageBox(oErr.UserValue,0+64,'提示！')
  Do While .T.
     lcCtrlFile=GetFile('OCX','输入文件名：','确定',0,'选择需要操作的文件')
     If Not File(lcCtrlFile,1) OR Empty(lcCtrlFile) Then
        lcMess='程序所必要的控件文件'+Iif(Empty(lcCtrlFile),'','['+lcCtrlFile+']')+'不存在！继续注册么？'
        If 6=MessageBox(lcMess,4+32+256,'系统提示！') Then
           Loop
        Else
           Quit
        Endif
     Endif
     oShell=CreateObject('Wscript.shell')
     lcRun="Regsvr32 /S "+lcCtrlFile
     If oShell.Run('&lcRun',0,.T.) != 0 Then && 隐藏窗口运行并返回错误代码(不为0,运行出错,注册失败)
        lcMess='选定的控件文件'+lcCtrlFile+'不包含控件'+lcCtrl+', 注册失败！继续注册么？'
        If 6=Messagebox(lcMess, 4+32+256, '信息提示') Then
           Loop
        Else
           Quit
        Endif
     Endif
     Try
       oCtrl=CreateObject(lcCheck)
     Catch To oErrExit
       oErrExit.UserValue = "OCX控件["+lcCtrl+"]未注册成功 或 与要求版本不符合！"
       =MessageBox(oErrExit.UserValue,0+64,'提示！')
       Quit
     Finally
     EndTry
     lcMess='控件['+lcCtrl+']注册成功！'
     =MessageBox(lcMess, 0+64, '系统提示！',5000)
     Exit
  EndDo
Finally
  Release oErr, oErrExit, lcCtrlFile, lcCtrl, lcRun, oCtrl, oShell, lcMess
EndTry
EndFunc

*************************

下面是网上摘抄的红雨先生的一个关于控件注册的函数，一并列示如下（本人未对该函数作过测试，对该函数的控件版本检测功能亦未判断，有兴趣者测试后可在此回复给我，谢谢）：

程序: 动态注册(dll、ocx)控件* 设计: 红雨*-------------------------------------------------
Clear
cLibFileName = getfile([注册控件(*.ocx,*.dll):ocx,dll],[控件文件])
If  !Empt(lcLibFileName)      
? DllRegister(lcLibFileName,.T.)  && 注册
*? DllRegister(lcLibFileName,.F.)  && 注销
Endif
Clea Dlls
Return

Function DllRegister (lpLibFileName,isReg)
isReg = iif(type("isReg")="U", .T., isReg)
lpProcName = iif(isReg, "DllRegisterServer", "DllUnregisterServer" )
Declare Integer GetLastError in kernel32
Declare Integer LoadLibrary in kernel32 String lpLibFileName
Declare Integer FreeLibrary in kernel32 Integer hLibModule
Declare Integer GetProcAddress in kernel32 Integer hModule, String lpProcName
Declare Integer CallWindowProc in user32 Integer lpPrevWndFunc, Integer hwnd, Integer Msg, Integer wParam, Integer lParam
hLibModule = LoadLibrary (lpLibFileName)
If hLibModule # 0
   lnAddress = GetProcAddress (hLibModule, lpProcName)
   If lnAddress # 0        
      If CallWindowProc( lnAddress, 0,0,0,0) = 0          
         = FreeLibrary (hLibModule)               
         Return "成功: " + lpProcName + " 地址: " + allt(str(lnAddress,12))
      Else
         lnerror = GetLastError()
      Endif
   Else
      lnerror = GetLastError()
   Endif
   = FreeLibrary (hLibModule)
Else
   lnerror = GetLastError()
Endif
Return "错误: (" + allt(str(lnerror)) + []) + GetErrorStr(lnerror)
End func
**************************

Function GetErrorStr (lpnError)
Declare INTEGER FormatMessage IN kernel32 INTEGER dwFlags, INTEGER lpSource, INTEGER dwMessageId,;
        INTEGER dwLanguageId, INTEGER @lpBuffer, INTEGER nSize, INTEGER  Arguments
Declare RtlMoveMemory IN kernel32 As CopyMemory STRING @Destination, INTEGER Source, INTEGER nLength
dwFlags = 256 + 4096 + 512
lpBuffer = 0
lnLength = FormatMessage(dwFlags, 0, lpnError, 0, @lpBuffer, 0, 0)
If lnLength <> 0
   lpResult = REPLI (Chr(0), 500)
   = CopyMemory (@lpResult, lpBuffer, lnLength)
   Return STRTRAN(LEFT(lpResult, lnLength), Chr(13)+Chr(10), "")
Else   
   Return "#<未知错误>#"
Endif
Endfunc

DECLARE INTEGER OpenClipboard               IN User32 INTEGER
DECLARE INTEGER CloseClipboard              IN User32
DECLARE INTEGER EmptyClipboard              IN User32
DECLARE INTEGER SetClipboardData            IN User32 INTEGER,INTEGER
DECLARE INTEGER LoadImage                   IN WIN32API INTEGER,String,INTEGER,INTEGER,INTEGER,INTEGER
DECLARE INTEGER GetClipboardData            IN User32 INTEGER
DECLARE INTEGER GdipCreateBitmapFromHBITMAP IN GdiPlus.dll INTEGER, INTEGER, INTEGER @
DECLARE INTEGER GdipSaveImageToFile         IN GdiPlus.dll INTEGER,String,String @,String @
DECLARE Long    GdipCreateHBITMAPFromBitmap IN GDIPLUS.DLL Long nativeImage, Long @, Long
DECLARE Long    GdipCreateBitmapFromFile    IN GDIPLUS.DLL String FileName, Long @nBitmap
DECLARE Long    CopyImage                   IN WIN32API Long hImage, Long, Long, Long , Long

#Define CF_BITMAP 2
#Define CF_DIB 8
#Define IMAGE_BITMAP 0
#Define LR_LOADFROMFILE 16

*1.将图形文件保存到剪切板
nBitmap=0
hbm=0
imagefile='图形文件名'
GdipCreateBitmapFromFile(STRCONV(imagefile+0h00,5),@nBitmap)
GdipCreateHBITMAPFromBitmap(nBitmap,@hbm,0)
lhBmp = CopyImage(hbm, 0, 0, 0, 0)
IF OpenClipboard(0)!= 0
   EmptyClipboard()
   SetClipboardData(CF_BITMAP, lhBmp)
   CloseClipboard()
ENDIF

*2.将剪切板图形保存到本地
OpenClipboard(0)
hBitmap = GetClipboardData(CF_BITMAP)
hDib = GetClipboardData(CF_DIB)
CloseClipboard()
uBitmap=0
GdipCreateBitmapFromHBITMAP(hBitmap,2,@uBitmap)
lcOutputFile=STRCONV('C:\_Temp1.jpg'+CHR(0),5)
*!* lqEncoderClsID_BMP=0h00F47C55041AD3119A730000F81EF32E &&BMP格式
lqEncoderClsID_JPG=0h01F47C55041AD3119A730000F81EF32E &&JPG格式
*!* lqEncoderClsID_GIF=0h02F47C55041AD3119A730000F81EF32E &&GIF格式
*!* lqEncoderClsID_TIF=0h05F47C55041AD3119A730000F81EF32E &&TIF格式
*!* lqEncoderClsID_PNG=0h06F47C55041AD3119A730000F81EF32E &&PNG格式
GdipSaveImageToFile(uBitmap,lcOutputFile,lqEncoderClsID_JPG,NULL)

*!* 关于身份证号码最后一位的校验码的算法如下：
*!* 我国现行使用公民身份证号码有两种尊循两个国家标准，〖GB 11643-1989〗和〖GB 11643-1999〗。
*!* 〖GB 11643-1989〗中规定的是15位身份证号码：排列顺序从左至右依次为：六位数字地址码，
*!* 六位数字出生日期码，三位数字顺序码，其中出生日期码不包含世纪数。
*!* 〖GB 11643-1999〗中规定的是18位身份证号码：公民身份号码是特征组合码，由十七位数字本体码和一位数字校验码组成。
*!* 排列顺序从左至右依次为：六位数字地址码，八位数字出生日期码，三位数字顺序码和一位数字校验码。
*!* 地址码表示编码对象常住户口所在县(市、旗、区)的行政区划代码。
*!* 生日期码表示编码对象出生的年、月、日，其中年份用四位数字表示，年、月、日之间不用分隔符。
*!* 顺序码表示同一地址码所标识的区域范围内，对同年、月、日出生的人员编定的顺序号。顺序码的奇数分给男性，偶数分给女性。
*!* 校验码是根据前面十七位数字码，按照ISO 7064:1983.Mod 11-2校验码计算出来的检验码。
*!* 公式如下：
*!* 　　∑(a[i]*W[i]) Mod 11 ( i = 2, 3, ..., 18 ) (1)
*!* 　　"*" 表示乘号
*!* 　　i--------表示身份证号码每一位的序号，从右至左，最左侧为18，最右侧为1。
*!* 　　a[i]-----表示身份证号码第 i 位上的号码
*!* 　　W[i]-----表示第 i 位上的权值 W[i] = 2^(i-1) Mod 11
*!* 　　计算公式 (1) 令结果为 R
*!* 根据下表找出 R 对应的校验码即为要求身份证号码的校验码C。
*!* 　　R 0 1 2 3 4 5 6 7 8 9 10
*!* 　　C 1 0 X 9 8 7 6 5 4 3 2
*!* 由此看出 X 就是 10，罗马数字中的 10 就是X，所以在新标准的身份证号码中可能含有非数字的字母X。
*!* *********************************************************************************
*!* 感谢yesyesyes提供的信息：
*!* 15位身份证那时是我国第一次发身份证
*!* 发证当时已满100岁的人,就给他们那些号(因为年份只有2位)
*!* 十五位身份证第十三至十五位为分配顺序代码
*!* 分配顺序码中“999、998、997、996”四个顺序号分别为男女性百岁以上老人专用的特定编号。
*!* *********************************************************************************
*!* 感谢清风提供的信息：
*!* 这里所说的“百岁”应该是指19世纪也就是18XX年出生的人，而不是指办身份证时此人已有100岁。这种特例不多，所以男女各设了两个序号
*!* 还得提醒一下，1901年与2001年不会发生冲突，因为2000后就直接使用18位号码了，如果是15位的，那肯定是2000年以前的。
*!* *****************************************************************************

*---------------------------------------------------------------
*此函数功能：输入的15位或18位身份证号，返回正确的18位的身份证号。
*---------------------------------------------------------------
Function IDCardTF
    Parameters cNumber
    #Define InvalidSize "身份证号码长度不正确！"
    #Define InvalidChar "身份证号码包括非法字符！"
    #Define InvalidDate "出生日期无效！"
    #Define InvalidReturnValue ".F."
    Private cString
    Do Case
        Case Len(cNumber) = 15
            cString = Stuff(cNumber,7,0,"19")
        Case Len(cNumber) = 18
            cString =Left(Alltrim(cNumber),17)
        Otherwise
            Messagebox(InvalidSize,48,"信息提示")
            Return InvalidReturnValue
    Endcase
    Private i,N,iRet
    Store 0 To iRet
    For i = 1 To 17
        N = Substr(cString,i,1)
        If Not Isdigit(N)
            Messagebox(invalidChar,48,"信息提示")
            Return invalidReturnValue
        Endif
        N = 2 ^ (18 - i) % 11 * Val(N)
        iRet = iRet + N
    Endfor
    iRet = iRet % 11 + 1
    Private oldDateSet, oldCentury
    Private oldStrictDate, BirthDay
    oldDateSet = Set("DATE")
    oldCentury = Set("CENTURY")
    oldStrictDate = Set("STRICTDATE")
    Set Date Ansi
    Set Century On
    Set StrictDate To 0
    BirthDay = Ctod(Substr(cString,7,4)+"-"+Substr(cString,11,2)+"-"+Substr(cString,13,2))
    Set StrictDate To &oldStrictDate
    Set Century &oldCentury
    Set Date &oldDateSet
    If Empty(BirthDay)
        Messagebox(InvalidDate,48,"信息提示")
        Return InvalidReturnValue
    Endif
    Return cString+Substr("10x98765432",iRet,1)
Endfunc

*----------------------------------------------------
*此函数功能：检验输入的15位或18位身份证号码是否为合法
*----------------------------------------------------
Function MyIdentityCardVerify &&校验身份证号是否合法
    Lparameters lstr &&参数:lstr 传入的号码
    Private lstr,relyn,tsfz,m1,m2,m3,m4,m,I,r,c,ai,wi
    relyn=.F. &&返回值
    tsfz=Alltrim(lstr)
    *分别用m1,m2,m3,m4表示四个条件是否成立
    Stor .T. To m1,m2,m3,m4
    *条件1：只能是15或18位
    m1=Iif(Len(tsfz)=15 Or Len(tsfz)=18,.T.,.F.)
    If Len(tsfz)=15 && 15位的号码
        For I=1 To 15 &&检查每一位是否为数字
            m=Asc(Substr(tsfz,I,1))
            If m<48 Or m>57 &&数字
                m2=.F. &&若有一位不是就不再查
                Exit
            Endif
        Endfor
        m="19" +Substr(tsfz, 7,2) &&早期的号都是上个世纪的
        m=m+"."+Substr(tsfz, 9,2)
        m=m+"."+Substr(tsfz,11,2)
        m=Ctod(m)
        If Isnull(m) Or Isblank(m)
            m3=.F. &&生日不正确
        Endif
    Endif
    If Len(tsfz)=18 && 18位的号码
        For I=1 To 17
            m=Asc(Substr(tsfz,I,1))
            If m<48 Or m>57
                m2=.F.
                Exit
            Endif
        Endfor
        m=Substr(tsfz,7,4)
        m=m+"."+Substr(tsfz,11,2)
        m=m+"."+Substr(tsfz,13,2)
        m=Ctod(m)
        If Isnull(m) Or Isblank(m)
            m3=.F.
        Endif
        r=0 &&计算校验位
        For I=18 To 2 Step -1
            ai=Val(Substr(tsfz,19-i,1))
            wi=Mod(2^(i-1),11)
            r=r+ai*wi
        Next
        r=Mod(r,11)
        Do Case
            Case r=0
                c="1"
            Case r=1
                c="0"
            Case r=2
                c="X"
            Otherwise
                c=Alltrim(Str(12-r))
        Endcase
        If Upper(Substr(tsfz,18,1))<>c
            m4=.F. &&校验位与原码最末位不同
        Endif
    Endif
    *四个条件全成立，则返回.t.
    relyn=Iif(m1 And m2 And m3 And m4,.T.,.F.)
    Return relyn
Endfunc

*--------------------------------------------------------------------------------------------
*此函数功能：输入15位或18位的身份证号，返回被校验后的18位的身份证号，若身份证号非法，则返回空
*--------------------------------------------------------------------------------------------
Function sfjy
    Parameters msfz
    On Error Return ''
    Dimension T(17)
    Private msfz,T,sn,i
    msfz=Alltrim(msfz)
    Do Case
        Case Len(msfz)=15
            msfz=Left(msfz,6)+'19'+Substr(msfz,7)
        Case Len(msfz)=18
            msfz=Left(msfz,17)
        Otherwise
            Return ''
    Endcase
    For i=1 To 17
        If !Isdigit(Substr(msfz,i,1))
            Return ''
        Endif
    Endfor
    If !Left(msfz,2)$'11,12,13,14,15,21,22,23,31,32,33,34,35,36,37,41,42,43,44,45,46,50,51,52,53,54,61,62,63,64,65,71,81,82'
        Return ''
    Endif
    If Empty(Date(Val(Substr(msfz,7,4)),Val(Substr(msfz,11,2)),Val(Substr(msfz,13,2))))
        Return ''
    Endif
    sn=0
    T(1)=7
    T(2)=9
    T(3)=10
    T(4)=5
    T(5)=8
    T(6)=4
    T(7)=2
    T(8)=1
    T(9)=6
    T(10)=3
    T(11)=7
    T(12)=9
    T(13)=10
    T(14)=5
    T(15)=8
    T(16)=4
    T(17)=2
    For i=1 To 17
        sn=sn+Val(Substr(msfz,i,1))*T(i)
    Endfor
    sn=Mod(sn,11)
    On Error
    Return msfz+Substr('10X98765432',sn+1,1)
Endfunc

*------------------------------------------------------------------
*此函数功能：输入的15位或17位或18位的身份证号，返回校验后的最后一位
*------------------------------------------------------------------
Function sfzjy
    Parameters cID
    Do Case
        Case Len(Alltrim(cID)) = 15
            cID = Stuff(Alltrim(cID),7,0,"19")
        Case Len(Alltrim(cID)) = 18 Or Len(Alltrim(cID)) = 17
            cID =Left(Alltrim(cID),17)
        Otherwise
            Return .F.
    Endcase
    If Len(Alltrim(cID))#17
        Return .F.
    Endif
    nSum= Val(Substr(cID,1,1)) * 7 ;
        + Val(Substr(cID,2,1)) * 9 ;
        + Val(Substr(cID,3,1)) * 10 ;
        + Val(Substr(cID,4,1)) * 5 ;
        + Val(Substr(cID,5,1)) * 8 ;
        + Val(Substr(cID,6,1)) * 4 ;
        + Val(Substr(cID,7,1)) * 2 ;
        + Val(Substr(cID,8,1)) * 1 ;
        + Val(Substr(cID,9,1)) * 6 ;
        + Val(Substr(cID,10,1)) * 3 ;
        + Val(Substr(cID,11,1)) * 7 ;
        + Val(Substr(cID,12,1)) * 9 ;
        + Val(Substr(cID,13,1)) * 10 ;
        + Val(Substr(cID,14,1)) * 5 ;
        + Val(Substr(cID,15,1)) * 8 ;
        + Val(Substr(cID,16,1)) * 4 ;
        + Val(Substr(cID,17,1)) * 2
    *计算校验位
    check_number=Int((12-nSum % 11)%11)
    If check_number=10
        check_number='X'
    Endif
    Return check_number
Endfunc

******************************************
*身份证号出错信息(对字段：sfzherrc的编码解释)
*1、"身份证号不满15位！"2、性别与身份证不符3、出生月份出错（不在1－12范围内）4、出生日期出错（不在1－31范围内）
*5、18位校验位出错（sfzherrc中紧跟括号内的内容为正确的第18位校验码）6、18位身份证出生年份出错（不是19）
*检查原则：不满15位只检查位数，15位检查出生年、月、日的超界关系、性别对应关系（男：身份证第15位为13579，女：身份证第15位为02468）
*检查原则：18位身份证除检查15位的检查原则外增加检查最后一位检验码的关系校验
*以下附身份证号的算法函数，可供大家参考！！
***********************************************************************
*身份号码第18位校验位的算法〖中华人民共和国国家标准 GB 11643-1999〗(依此算法写的函数存放在过*程文件myproc.prg中<附后>)
* 15位的身份证编码首先把出生年扩展为4位，简单的就是增加一个19，但对于1900前年出生的人不适用
* ∑(ai×Wi)(mod 11)……………………………………(1)
* 公式(1)中：
* i----表示号码字符从由至左包括校验码在内的位置序号；
* ai----表示第i位置上的号码字符值；
* Wi----示第i位置上的加权因子，其数值依据公式Wi=2^(n-1)(mod 11)计算得出（(n-1)为幂）。
* i 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1
* ai 3 4 0 5 2 4 1 9 8 0 0 1 0 1 0 0 1 a1
* Wi 7 9 10 5 8 4 2 1 6 3 7 9 10 5 8 4 2 1
* ai×Wi 21 36 0 25 16 16 2 9 48 0 0 9 0 5 0 0 2 a1
* 根据公式(1)进行计算：
* ∑(ai×Wi) =（21+36+0+25+16+16+2+9+48++0+0+9+0+5+0+0+2) = 189
* 189 ÷ 11 = 17 + 2/11
* ∑(ai×Wi)(mod 11) = 2
* 然后根据计算的结果，从下面的表中查出相应的校验码，其中X表示计算结果为10：
* ∑(ai×WI)(mod 11) 0 1 2 3 4 5 6 7 8 9 10
* 校验码字符值ai 1 0 X 9 8 7 6 5 4 3 2

*-----------------------------
*身份证升位程序
*作者：窦学田
*功能：计算身份证的校验码
*入口参数：15位号码 或17位号码
*返回：18位身份证号码
*-----------------------------
Function NewIdCode()
    Parameters OldId
    Local id1,id2,i2,NewIdCode
    id1=Strtran(OldId,' ','')
    id2=0
    If Len(id1)=15
        id1=Left(OldId,6)+'19'+Right(OldId,9)
    Endif
    If Len(id1)=17
        For i2=1 To 17
            id2=id2+Val(Substr(id1,18-i2,1))*(Mod(2^i2,11))
        Endfor
        id1=id1+Iif(Mod(1-id2,11)=10,'X',Str(Mod(1-id2,11),1))
    Endif
    NewIdCode=id1
    Return NewIdCode
Endfunc

*-----------------------------
*测试18位的身份证是否正确
*作者：窦学田
*功能：测试18位身份证的校验码
*入口参数：18位号码
*返回：出错信息
*-----------------------------
Function GetOld()
    Parameters sID
    s1=' 7 910 5 8 4 2 1 6 3 7 910 5 8 4 2'
    s2='10X98765432'
    sID=Upper(Alltrim(sID))
    If Len(sID)=15
        sID=Stuff(sID,7,0,"19")
    Endif
    NewId=Left(sID,17)
    jym=0
    For i=1 To 17
        jym=jym+Val(Substr(s1,i*2-1,2))*Val(Substr(NewId,i,1))
    Endfor
    NewId= NewId+ Substr(s2,Mod(jym,11)+1,1)
    If Len(sID)=18
        If Right(sID,1)<>Right(NewId,1) &&正确
            Messagebox(sID+"为错误身份证号码！",48,"警告")
        Endif
    Endif
Endfunc

*---------------------------------------------------
*测试身份证的年月日的合法性YMDS(year,month,date,sex)
*作者：窦学田
*功能：测试18位身份证的年月日的合法性
*入口参数：原表中的性别代码,原身份证号码
*返回：综合出错信息
*---------------------------------------------------
Function CheckYMDS()
    Parameters F_xbdm,F_ID
    Local rtn_errcode
    rtn_errcode=''
    sfxb=Iif(F_xbdm='1','13579','02468')
    If Len(Alltrim(F_ID))=15
        sfsex=Substr(F_ID,15,1)
        If !sfsex$sfxb &&测试性别
            rtn_errcode=Iif(Empty(rtn_errcode),"2",Alltrim(rtn_errcode)+'+2')
        Endif
        sfy=Substr(F_ID,9,2) &&月
        sfr=Substr(F_ID,11,2) &&日
        If !(Val(sfy)<=12)
            rtn_errcode=Iif(Empty(rtn_errcode),"3",Alltrim(rtn_errcode)+'+3')
        Endif
        If !(Val(sfr)<=31)
            rtn_errcode=Iif(Empty(rtn_errcode),"4",Alltrim(rtn_errcode)+'+4')
        Endif
    Else
        sfsex=Substr(F_ID,17,1)
        If !sfsex$sfxb &&测试性别
            rtn_errcode=Iif(Empty(rtn_errcode),"2",Alltrim(rtn_errcode)+'+2')
        Endif
        sfy=Substr(F_ID,11,2) &&月
        sfr=Substr(F_ID,13,2) &&日
        If !(Val(sfy)<=12) &&月
            rtn_errcode=Iif(Empty(rtn_errcode),"3",Alltrim(rtn_errcode)+'+3')
        Endif
        If !(Val(sfr)<=31) &&日
            rtn_errcode=Iif(Empty(rtn_errcode),"4",Alltrim(rtn_errcode)+'+4')
        Endif
    Endif
    *以下测试第18位校验码的正确性
    s1=' 7 910 5 8 4 2 1 6 3 7 910 5 8 4 2'
    s2='10X98765432'
    F_ID=Upper(Alltrim(F_ID))
    If Len(F_ID)=15
        F_ID=Stuff(F_ID,7,0,"19")
    Endif
    NewId=Left(F_ID,17)
    jym=0
    For i=1 To 17
        jym=jym+Val(Substr(s1,i*2-1,2))*Val(Substr(NewId,i,1))
    Endfor
    NewId= NewId+ Substr(s2,Mod(jym,11)+1,1)
    If Len(F_ID)=18
        If Right(F_ID,1)<>Right(NewId,1) &&不正确
            &&返回出错信息及正确的第18位校验码
            rtn_errcode=Iif(Empty(rtn_errcode),"5"+'(应为'+Right(NewId,1)+')',Alltrim(rtn_errcode)+'+5'+'(应为'+Right(NewId,1)+')')
        Endif
    Endif
    If Substr(F_ID,7,2)<>'19' &&测试年（19）
        rtn_errcode=Iif(Empty(rtn_errcode),"6",Alltrim(rtn_errcode)+'+6')
    Endif
    Return rtn_errcode
Endfunc

*------------------------------------------------------
* 从身份证在返回相关资料
* 第一个参数为[字符型]:身份证号码
* 第二个参数为返回资料[数值型]:1.返回为行政区号[字符符]
* 2.返回为出生日期[日期型]
* 3.返回为性别男女[字符型]
* 没有第二参数时返回正确的18位身份证号码
* 梦幻幻影 2005-04-22 17:12:18 *
*------------------------------------------------------
Function IDCardCheck ( c_IDCard,nRetValue )
    If Vartype(m.c_IDCard) <> [C] Or Not Inlist(Len(Alltrim(m.c_IDCard)),15,18)
        Return .F.
    Endif
    If Len(Alltrim(m.c_IDCard)) = 15
        m.c_IDCard = Substr(m.c_IDCard,1,6)+[19]+Substr(m.c_IDCard,7) + [X]
    Endif
    m.nRetValue = Iif(Vartype(m.nRetValue) = [N],m.nRetValue,0)
    Local nEndCode,ReString
    m.nEndCode = 0
    For i=17 To 1 Step -1
        m.nEndCode = m.nEndCode +(2^i%11)*Val(Substr(c_idcard,18-i,1))
    Endfor
    Do Case
        Case m.nRetValue = 1 &&返回行政区号
            m.ReString = Substr(m.c_IDCard,1,6)
        Case m.nRetValue = 2 &&返回出生日期
            m.ReString = Substr(m.c_IDCard,7,8)
            Local nYear,nMonth,nDay
            m.nYear = Val(Substr(m.ReString,1,4))
            m.nMonth = Val(Substr(m.ReString,5,2))
            m.nDay = Val(Substr(m.ReString,7,2))
            If !Between(m.nMonth, 1, 12)
                Return .F.
            Endif
            Do Case
                Case Inlist(m.nMonth,4,6,9,11)
                    If !Between(m.nDay,1,30)
                        Return .F.
                    Endif
                Case m.nMonth = 2
                    If !Between(m.nDay,1,Iif(Int(m.nYear/4) = m.nYear/4,29,28))
                        Return .F.
                    Endif
                Otherwise
                    If !Between(m.nDay,1,31)
                        Return .F.
                    Endif
            Endcase
            Return Date(m.nYear,m.nMonth,m.nDay)
        Case m.nRetValue = 3 &&返回性别
            m.ReString = Substr(Right(m.c_IDCard,2),1,1)
            m.ReString = Iif(Mod(Val(m.ReString),2)=0,[女],[男])
        Otherwise
            m.ReString = Substr([10X98765432],Mod(m.nEndCode,11)+1,1)
            m.ReString = Substr(m.c_IDCard,1,17) + m.ReString
    Endcase
    Return m.ReString
Endfunc

*------------------------------------------------------
*感谢：dfwxj(清风)
*------------------------------------------------------
Function sfjy
    Parameters msfz
    On Error Return ''
    Private msfz,sn,i,dic
    dic='0709100508040201060307091005080402'
    msfz=Alltrim(msfz)
    *出生日期预处理，仅接受15或18位字符串
    Do Case
        Case Len(msfz)=15
            If Right(msfz,3)$'996,997,998,999'
                msfz=Left(msfz,6)+'18'+Substr(msfz,7)
            Else
                msfz=Left(msfz,6)+'19'+Substr(msfz,7)
            Endif
        Case Len(msfz)=18
            msfz=Left(msfz,17)
        Otherwise
            Return ''
    Endcase
    *检查身份证号字符的合法性
    For i=1 To 17
        If !Isdigit(Substr(msfz,i,1))
            Return ''
        Endif
    Endfor
    *检查行政区划合法性
    If !Left(msfz,2)$'11,12,13,14,15,21,22,23,31,32,33,34,35,36,37,41,42,43,44,45,46,50,51,52,53,54,61,62,63,64,65,71,81,82'
        Return ''
    Endif
    *检查出生日期合法性
    If Empty(Date(Val(Substr(msfz,7,4)),Val(Substr(msfz,11,2)),Val(Substr(msfz,13,2))))
        Return ''
    Endif
    *生成校检码
    sn=0
    For i=1 To 17
        sn=sn+Val(Substr(msfz,i,1))*Val(Substr(dic,i*2-1,2))
    Endfor
    sn=Mod(sn,11)
    On Error
    Return msfz+Substr('10X98765432',sn+1,1)
Endfunc

*------------------------------------------------------
*作者：Linzhiyang，发表于『动感游标』 http://www.vfp.cn
*若转载，请保留本注释部分
*功能：计算身份证的校验码
*入口参数：15位号码 或17位号码
*返回：18位身份证号码
*------------------------------------------------------
Function NewIdCode
    Parameters OldId
    Local id1,id2,i,NewId
    id1=Strtran(OldId," ","")
    id2=0
    Do Case
        Case Len(id1)=15
            id1=Left(OldId,6)+"19"+Right(OldId,9)
            For i=1 To 17
                id2=id2+Val(Substr(id1,18-i,1))*(Mod(2^i,11))
            Endfor
            id1=id1+Iif(Mod(1-id2,11)=10,"X",Str(Mod(1-id2,11),1))
        Case Len(id1)=17
            For i=1 To 17
                id2=id2+Val(Substr(id1,18-i,1))*(Mod(2^i,11))
            Endfor
            id1=id1+Iif(Mod(1-id2,11)=10,"X",Str(Mod(1-id2,11),1))
        Otherwise
            id1="Error"
    Endcase
    NewId=id1
    Return NewId
Endfunc

*----------------
*18位身份证校验码
*----------------
Function valid_Id_Card_Num
    Lparameters cIdCardNo18
    Local s,i,b,Y,LastChart, StrValid, Wi
    StrValid = '10X98765432'
    Wi = '7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2,1'
    S=0
    For i = 1 To 17
        b = Val(Substr(cIdCardNo18,i,1))
        S = S + b * Val(Getwordnum(wi,i,','))
    Endfor
    Y= Mod(s,11) + 1
    LastChart = Substr(StrValid,Y,1)
    Return LastChart
Endfunc

本文来自CSDN博客，转载请标明出处：http://blog.csdn.net/apple_8180/archive/2006/07/19/941626.aspx

本文来自CSDN博客，转载请标明出处：http://blog.csdn.net/apple_8180/archive/2008/12/22/3583601.aspx

Declare Integer FindWindow In user32 String lpClassName,String lpWindowName
Declare Integer FindWindowEx In user32 Integer hwndParent,Integer hwndChildAfter,String @lpszClass,String @lpszWindow
Declare Integer SendMessage In user32 Integer,Integer,Integer,String @
#Define WM_GETTEXT 0xD
lcCaption="要查找窗口的Caption" &&要查找窗口的标题
lnHandle=FindWindow(Null,lcCaption)
If lnHandle>0
    lnSendHwnd=0
    Do While .T.
        lnSendHwnd=FindWindowEx(lnHandle,lnSendHwnd,"Edit",Null) &&获得输入框句柄
        If lnSendHwnd<>0
            lcTextValue=Space(255)
            SendMessage(lnSendHwnd,WM_GETTEXT,255,@lcTextValue) &&获取输入框内容
            ?lcTextValue &&显示得到的输入框内容
        Else
            Exit
        Endif
    Enddo
Else
    Messagebox("没有找到 ["+lcCaption+"] 窗体！"+Space(5),48,"信息提示")
Endif

本文来自CSDN博客，转载请标明出处：http://blog.csdn.net/apple_8180/archive/2009/04/07/4054601.aspx

Select CONVERT(varchar, GETDATE(), 0): 05 16 2006 10:57AM
Select CONVERT(varchar, GETDATE(), 1): 05/16/06
Select CONVERT(varchar, GETDATE(), 2): 06.05.16
Select CONVERT(varchar, GETDATE(), 3): 16/05/06
Select CONVERT(varchar, GETDATE(), 4): 16.05.06
Select CONVERT(varchar, GETDATE(), 5): 16-05-06
Select CONVERT(varchar, GETDATE(), 6): 16 05 06
Select CONVERT(varchar, GETDATE(), 7): 05 16, 06
Select CONVERT(varchar, GETDATE(), 8): 10:57:46
Select CONVERT(varchar, GETDATE(), 9): 05 16 2006 10:57:46:827AM
Select CONVERT(varchar, GETDATE(), 10): 05-16-06
Select CONVERT(varchar, GETDATE(), 11): 06/05/16
Select CONVERT(varchar, GETDATE(), 12): 060516
Select CONVERT(varchar, GETDATE(), 13): 16 05 2006 10:57:46:937
Select CONVERT(varchar, GETDATE(), 14): 10:57:46:967
Select CONVERT(varchar, GETDATE(), 20): 2006-05-16 10:57:47
Select CONVERT(varchar, GETDATE(), 21): 2006-05-16 10:57:47.157
Select CONVERT(varchar, GETDATE(), 22): 05/16/06 10:57:47 AM
Select CONVERT(varchar, GETDATE(), 23): 2006-05-16
Select CONVERT(varchar, GETDATE(), 24): 10:57:47
Select CONVERT(varchar, GETDATE(), 25): 2006-05-16 10:57:47.250
Select CONVERT(varchar, GETDATE(), 100): 05 16 2006 10:57AM
Select CONVERT(varchar, GETDATE(), 101): 05/16/2006
Select CONVERT(varchar, GETDATE(), 102): 2006.05.16
Select CONVERT(varchar, GETDATE(), 103): 16/05/2006
Select CONVERT(varchar, GETDATE(), 104): 16.05.2006
Select CONVERT(varchar, GETDATE(), 105): 16-05-2006
Select CONVERT(varchar, GETDATE(), 106): 16 05 2006
Select CONVERT(varchar, GETDATE(), 107): 05 16, 2006
Select CONVERT(varchar, GETDATE(), 108): 10:57:49
Select CONVERT(varchar, GETDATE(), 109): 05 16 2006 10:57:49:437AM
Select CONVERT(varchar, GETDATE(), 110): 05-16-2006
Select CONVERT(varchar, GETDATE(), 111): 2006/05/16
Select CONVERT(varchar, GETDATE(), 112): 20060516
Select CONVERT(varchar, GETDATE(), 113): 16 05 2006 10:57:49:513
Select CONVERT(varchar, GETDATE(), 114): 10:57:49:547
Select CONVERT(varchar, GETDATE(), 120): 2006-05-16 10:57:49
Select CONVERT(varchar, GETDATE(), 121): 2006-05-16 10:57:49.700
Select CONVERT(varchar, GETDATE(), 126): 2006-05-16T10:57:49.827
Select CONVERT(varchar, GETDATE(), 130): 18 ???? ?????? 1427 10:57:49:907AM
Select CONVERT(varchar, GETDATE(), 131): 18/04/1427 10:57:49:920AM

其中：130、131代表科威特标准即中东标准，中国近似为回历

血型是如何遗传的？
在日常生活中，人们常用一些不规范的方法来推测、判断父母与子女之间的血缘关系，却往往得出错误的结论，引起一些不必要的纠纷。如果从基因的角度来判断血型的遗传关系，就能避免父母与子女之间血缘关系的判断错误。
遗传学研究证明，人的血型同其他所有遗传性状一样，都是由染色体上的基因决定的。我们通常说的ABO血型基因在9号染色体上，科学家早就发现控制人的ABO血型基因有不同的三种，即A、B和O基因，而每条9号染色体上只容得上述三种基因中的任何一种血型基因。这样，来自父母双方两条染色体上的基因匹配就可能出现6种形式：OO，AA，AO，BB，BO，AB，即可能产生6种不同的遗传血型。至于每个人到底是哪种遗传血型，那就要看他从父亲和母亲身上分别传下来的是哪种基因。
通常，人的血型分为A型、B型、O型及AB型4种类型。而为什么血型的遗传型却有前面所说的6种类型，其两者之间有着以下的关系：即如果一个人血型的遗传类型为OO型，则他(她)的血型为O型；如果遗传类型为AA型，则血型为A型；如果遗传类型为AO型，则其血型也为A型；如果遗传类型为BB型，则其血型为B型；如果遗传类型为BO型，则其血型也为B型；如果一个人的血型遗传类型为AB型，则其血型也是AB型。

Rh血型简介
一、什么是Rh血型?
人类红细胞血型由多达二十多种的血型系统组成，ABO和Rh血型是与人类输血关系最为密切的两个血型系统。当一个人的红细胞上存在一种D血型物质(抗原)时，则称为Rh阳性，用Rh(+)表示；当缺乏D抗原时即为Rh阴性，用RH(-)表示。
二、Rh(-)属稀有血型吗?
Rh(-)的分布因种族不同而差异很大，在白种人中的比例较高，约百分之十五。中国人群中，新疆维吾尔等少数民族Rh(-)的分布为百分五；蒙古族人接近百分之一；汉族人所占的比例极少，仅千分之三，属稀有血型。如果同时考虑ABO和Rh血型系统，在汉族人群中寻找AB型Rh(-)同型人的机会不到万分之三，十分罕见。
三、Rh血型是如何遗传的?
Rh(-)基因是隐性基因。当Rh(+)的父母带有Rh(-)基因，且同时遗传给子代时，其孩子即表现为Rh(-)，双亲有一人是Rh(-)时，其子女为Rh(-)的机会增大，反之机会减少。
四、Rh(-)有何意义?
无论是Rh(-)者还是Rh(+)者其差别仅仅是血型的不同，都属健康人群。但Rh(-)者遇到特殊时其临床意义不容忽视，如连续两胎母婴Rh血型不合的妊娠，很可能导致胎儿的严重伤害；又如有输血、人流等免疫史的病人再次输入Rh(+)血时，可能产生强烈的溶血性输血反应。
五、Rh(-)者如何自我保护?
请您记住这条原则：血液只能同型输注，即A型Rh(-)患者只能输A型Rh(-)血，B型的只能输B型Rh(-)血，假如您生病或手术需要输血时，您一定要将您是Rh(-)血型的情况告知医生，以便医生及早和市血液中心联系，组织您所需要的Rh(-)血源。假如您是未育女性，请您做好计划生育以避免人工流产，若您已有流产或输血史，妊娠期务必到血站血型室进行新生儿溶血病的预测检查，以防止今后新生儿溶血病的发生。
六、您知道血型工作者已经为您做了哪些工作吗?
紧急情况时能否及时向Rh(-)患者供应同型血液是一件性命悠关的大事，血液中心的血型工作者以保障每一位Rh(-)患者的输血安全为己任，常年不懈地对数以万计的供血人群进行Rh(-)血型筛选，一旦筛选到Rh(-)血，这袋血就立即做上特殊的标记并保存在4℃冰箱中以备急需。
七、Rh(-)者输血供应有保障吗?
尽管输血工作者防患于未然已竭尽全力，但紧急情况时Rh(-)者可能缺乏同型而危及生命的潜在危险依然存在。其实，消除这一困扰的方法很简单：即所有Rh(-)者同舟共济，在随时作为可能的受血者的同时，也随时作为一名高尚的供血者，这样您和所有的Rh(-)者的生命都将得保障。

*-----------------------------------------------
* 测试 GetProcedreCode()
*-----------------------------------------------
Local lcDataBaseName, lcProcedreName, lcProcedreCode, lnSqlHandle, lcSqlStringConnect
lcProcedreCode = []
lcDataBaseName = [DCLZ]
lcProcedreName = [dbo.ins考勤原始表]
lcSqlStringConnect = [driver={Sql server};server=(local);uid=sa;pwd=Admin;database=Master]
lnSqlHandle = Sqlstringconnect( lcSqlStringConnect )
If lnSqlHandle > 0
    = SQLSetprop(lnSqlHandle,[DispWarnings], (.T.))
    lcProcedreCode = GetProcedreCode( lnSqlHandle, lcDataBaseName, lcProcedreName )
    = SQLDisconnect(lnSqlHandle)
    If !Empty(lcProcedreCode)
        _Cliptext = lcProcedreCode
        Modify File ([(]+lcDataBaseName+[)]+lcProcedreName+[.sql]) Nowait
        Keyboard [{CTRL+A}]
        Keyboard [{CTRL+V}]
    Endif
Endif
Return
*-----------------------------------------------

*-----------------------------------------------
* 函数: 获取SQL Server加密存储过程、函数、
*       视图、触发器  脚本，字节不受限制
* 设计: 红雨
* 时间: 2004.04.01
*-----------------------------------------------
Function GetProcedreCode( tnSqlHandle, tcDataBase, tcObjectName )
    *-----------------------------------------------
    #Define CR Chr(13)+Chr(10)
    Local lcReturn, lcTmpCursor, lcMyProcedure
    m.lcReturn = []
    m.lcTmpCursor = [T]+Sys(2015)
    m.lcDataBase = Iif(Type([m.tcDataBase])=[C] And !Empty(m.tcDataBase), m.tcDataBase, [Master])
    If Used(m.lcTmpCursor)
        Use In (m.lcTmpCursor)
    Endif
    *-----------------------------------------------
    If Type([m.tnSqlHandle])=[N] And m.tnSqlHandle>0 And Type([m.tcObjectName])=[C]
        = Sqlexec(m.tnSqlHandle, "use " + m.lcDataBase )
        m.lcMyProcedure = "CREATE PROCEDURE " + m.lcTmpCursor + "( @objectName varchar(50) )" ;
            +CR+ " AS" ;
            +CR+ " begin" ;
            +CR+ " set nocount on" ;
            +CR+ " begin tran" ;
            +CR+ " "
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ " Declare @objectname1 varchar(100)," ;
            +CR+ "         @orgvarbin varbinary(8000)" ;
            +CR+ " Declare @sql1 nvarchar(4000)," ;
            +CR+ "         @sql2 varchar(8000)," ;
            +CR+ "         @sql3 nvarchar(4000)," ;
            +CR+ "         @sql4 nvarchar(4000)" ;
            +CR+ " Declare @OrigSpText1 nvarchar(4000)," ;
            +CR+ "         @OrigSpText2 nvarchar(4000)," ;
            +CR+ "         @OrigSpText3 nvarchar(4000)," ;
            +CR+ "         @resultsp nvarchar(4000)," ;
            +CR+ "         @ptrval binary(16)," ;
            +CR+ "         @prvlen Int" ;
            +CR+ " Declare @i Int," ;
            +CR+ "         @Status Int," ;
            +CR+ "         @Type varchar(10)," ;
            +CR+ "         @parentid Int" ;
            +CR+ " Declare @colid Int," ;
            +CR+ "         @N Int," ;
            +CR+ "         @q Int," ;
            +CR+ "         @j Int," ;
            +CR+ "         @k Int," ;
            +CR+ "         @Encrypted Int," ;
            +CR+ "         @Number Int"
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ " Select @Type=xtype, @parentid=parent_obj From sysobjects Where Id=object_id(@ObjectName)" ;
            +CR+ " " ;
            +CR+ " If exists (select * from dbo.sysobjects where id = object_id(N'#result') and OBJECTPROPERTY(id, N'IsUserTable') = 1)" ;
            +CR+ "   Drop Table #result" ;
            +CR+ " Create Table #result(ProcName varchar(50), ProcCode text)" ;
            +CR+ " Insert #result values (@ObjectName, '')" ;
            +CR+ " " ;
            +CR+ " If exists (select * from dbo.sysobjects where id = object_id(N'#temp') and OBJECTPROPERTY(id, N'IsUserTable') = 1)" ;
            +CR+ "   Drop Table #temp" ;
            +CR+ " Create Table #temp(Number Int,colid Int,ctext varbinary(8000),Encrypted Int,Status Int)" ;
            +CR+ " Insert #temp Select Number,colid,ctext,Encrypted,Status From syscomments Where Id = object_id(@objectName)" ;
            +CR+ " " ;
            +CR+ " Select @Number=Max(Number) From #temp" ;
            +CR+ " Set @k=0" ;
            +CR+ " "
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ " While @k<=@Number" ;
            +CR+ "   Begin" ;
            +CR+ "   If Exists(Select 1 From syscomments Where Id=object_id(@objectname) And Number=@k)" ;
            +CR+ "     Begin" ;
            +CR+ "     If @Type='P'" ;
            +CR+ "       Set @sql1=(" ;
            +CR+ "         CASE" ;
            +CR+ "           When @Number>1 Then 'ALTER PROCEDURE '+ @objectName +';'+Rtrim(@k)+' WITH ENCRYPTION AS '" ;
            +CR+ "           Else 'ALTER PROCEDURE '+ @objectName+' WITH ENCRYPTION AS '" ;
            +CR+ "         END      )" ;
            +CR+ "     If @Type='TR'" ;
            +CR+ "       Begin" ;
            +CR+ "       Declare @parent_obj varchar(255)," ;
            +CR+ "               @tr_parent_xtype varchar(10)" ;
            +CR+ "       Select @parent_obj = parent_obj From sysobjects Where Id=object_id(@objectName)" ;
            +CR+ "       Select @tr_parent_xtype = xtype From sysobjects Where Id=@parent_obj" ;
            +CR+ "       If @tr_parent_xtype='V'" ;
            +CR+ "         Begin" ;
            +CR+ "         Set @sql1='ALTER TRIGGER '+@objectname+' ON '+OBJECT_NAME(@parentid)+' WITH ENCRYPTION INSTERD OF INSERT AS PRINT 1 '" ;
            +CR+ "         End" ;
            +CR+ "       Else" ;
            +CR+ "         Begin" ;
            +CR+ "         Set @sql1='ALTER TRIGGER '+@objectname+' ON '+OBJECT_NAME(@parentid)+' WITH ENCRYPTION FOR INSERT AS PRINT 1 '" ;
            +CR+ "         End" ;
            +CR+ "       End" ;
            +CR+ "     If @Type='FN' Or @Type='TF' Or @Type='IF'" ;
            +CR+ "       Set @sql1=(" ;
            +CR+ "         Case @Type" ;
            +CR+ "           When 'TF' Then 'ALTER FUNCTION '+ @objectName+'(@a char(1)) returns @b table(a varchar(10)) with encryption as begin insert @b select @a return end '" ;
            +CR+ "           When 'FN' Then 'ALTER FUNCTION '+ @objectName+'(@a char(1)) returns char(1) with encryption as begin return @a end'" ;
            +CR+ "           When 'IF' Then 'ALTER FUNCTION '+ @objectName+'(@a char(1)) returns table with encryption as return select @a as a'" ;
            +CR+ "         END      )" ;
            +CR+ "     If @Type='V'" ;
            +CR+ "       Set @sql1='ALTER VIEW '+@objectname+' WITH ENCRYPTION AS SELECT 1 as f'" ;
            +CR+ " "
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ "     Set @q=Len(@sql1)" ;
            +CR+ "     Set @sql1=@sql1+Replicate('-',4000-@q)" ;
            +CR+ "     Select @sql2=Replicate('-',8000)" ;
            +CR+ "     Set @sql3='exec(@sql1'" ;
            +CR+ "     Select @colid=Max(colid) From #temp Where Number=@k" ;
            +CR+ "     Set @N=1" ;
            +CR+ "     While @N<=Ceiling(1.0*(@colid-1)/2) And Len(@sQL3)<=3996" ;
            +CR+ "       Begin" ;
            +CR+ "       Set @sql3=@sql3+'+@'" ;
            +CR+ "       Set @N=@N+1" ;
            +CR+ "       End" ;
            +CR+ "     Set @sql3=@sql3+')'" ;
            +CR+ "     Exec sp_executesql @sql3,N'@Sql1 nvarchar(4000),@ varchar(8000)',@sql1=@sql1,@=@sql2" ;
            +CR+ "     End" ;
            +CR+ "   Set @k=@k+1" ;
            +CR+ "   End" ;
            +CR+ " "
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ " Set @k=0" ;
            +CR+ " While @k<=@Number" ;
            +CR+ "   Begin" ;
            +CR+ "   If Exists(Select 1 From syscomments Where Id=object_id(@objectname) And Number=@k)" ;
            +CR+ "     Begin" ;
            +CR+ "     Select @colid=Max(colid) From #temp Where Number=@k" ;
            +CR+ "     Set @N=1" ;
            +CR+ "     While @N<=@colid" ;
            +CR+ "       Begin" ;
            +CR+ "       Select @OrigSpText1=ctext,@Encrypted=Encrypted,@Status=Status From #temp Where colid=@N And Number=@k" ;
            +CR+ "       Set @OrigSpText3=(Select ctext From syscomments Where Id=object_id(@objectName) And colid=@N And Number=@k)" ;
            +CR+ "       If @N=1" ;
            +CR+ "         Begin" ;
            +CR+ " "
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ "         If @Type='P'" ;
            +CR+ "           Set @OrigSpText2=(" ;
            +CR+ "             CASE" ;
            +CR+ "               When @Number>1 Then 'CREATE PROCEDURE '+ @objectName +';'+Rtrim(@k)+' WITH ENCRYPTION AS '" ;
            +CR+ "               Else 'CREATE PROCEDURE '+ @objectName +' WITH ENCRYPTION AS '" ;
            +CR+ "             END            )" ;
            +CR+ " "
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ "         If @Type='FN' Or @Type='TF' Or @Type='IF'" ;
            +CR+ "           Set @OrigSpText2=(" ;
            +CR+ "             Case @Type" ;
            +CR+ "               When 'TF' Then 'CREATE FUNCTION '+ @objectName+'(@a char(1)) returns @b table(a varchar(10)) with encryption as begin insert @b select @a return end '" ;
            +CR+ "               When 'FN' Then 'CREATE FUNCTION '+ @objectName+'(@a char(1)) returns char(1) with encryption as begin return @a end'" ;
            +CR+ "               When 'IF' Then 'CREATE FUNCTION '+ @objectName+'(@a char(1)) returns table with encryption as return select @a as a'" ;
            +CR+ "             END            )" ;
            +CR+ " "
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ "         If @Type='TR'" ;
            +CR+ "           Begin" ;
            +CR+ "           If @tr_parent_xtype='V'" ;
            +CR+ "             Begin" ;
            +CR+ "             Set @OrigSpText2='CREATE TRIGGER '+@objectname+' ON '+OBJECT_NAME(@parentid)+' WITH ENCRYPTION INSTEAD OF INSERT AS PRINT 1 '" ;
            +CR+ "             End" ;
            +CR+ "           Else" ;
            +CR+ "             Begin" ;
            +CR+ "             Set @OrigSpText2='CREATE TRIGGER '+@objectname+' ON '+OBJECT_NAME(@parentid)+' WITH ENCRYPTION FOR INSERT AS PRINT 1 '" ;
            +CR+ "             End" ;
            +CR+ "           End" ;
            +CR+ " "
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ "         If @Type='V'" ;
            +CR+ "           Set @OrigSpText2='CREATE VIEW '+@objectname+' WITH ENCRYPTION AS SELECT 1 as f'" ;
            +CR+ " " ;
            +CR+ "         Set @q=4000-Len(@OrigSpText2)" ;
            +CR+ "         Set @OrigSpText2=@OrigSpText2+Replicate('-',@q)" ;
            +CR+ "         End" ;
            +CR+ "       Else" ;
            +CR+ "         Begin" ;
            +CR+ "         Set @OrigSpText2=Replicate('-', 4000)" ;
            +CR+ "         End" ;
            +CR+ " "
        lcMyProcedure = lcMyProcedure ;
            +CR+ "       Set @i=1" ;
            +CR+ "       Set @resultsp = Replicate(N'A', (datalength(@OrigSpText1) / 2))" ;
            +CR+ " " ;
            +CR+ "       While @i<=datalength(@OrigSpText1)/2" ;
            +CR+ "         Begin" ;
            +CR+ "         Set @resultsp = Stuff(@resultsp, @i, 1," ;
            +CR+ "           NCHAR(UNICODE(Substring(@OrigSpText1, @i, 1)) ^" ;
            +CR+ "                (UNICODE(Substring(@OrigSpText2, @i, 1)) ^" ;
            +CR+ "                 UNICODE(Substring(@OrigSpText3, @i, 1)))))" ;
            +CR+ "         Set @i=@i+1" ;
            +CR+ "         End" ;
            +CR+ " "
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ "       Set @orgvarbin=cast(@OrigSpText1 As varbinary(8000))" ;
            +CR+ "       Set @resultsp=(" ;
            +CR+ "         Case " ;
            +CR+ "           When @Encrypted=1 Then @resultsp" ;
            +CR+ "           Else convert(nvarchar(4000)," ;
            +CR+ "             Case " ;
            +CR+ "               When @Status&2=2 Then uncompress(@orgvarbin)" ;
            +CR+ "               Else @orgvarbin" ;
            +CR+ "             END        )" ;
            +CR+ "         END          )" ;
            +CR+ "       Print @resultsp" ;
            +CR+ "       select @ptrval = TEXTPTR(ProcCode) from #result" ;
            +CR+ "       select @prvlen = DATALENGTH(ProcCode) from #result" ;
            +CR+ "       UPDATETEXT #result.ProcCode @ptrval @prvlen 0 @resultsp" ;
            +CR+ " "
        m.lcMyProcedure = m.lcMyProcedure ;
            +CR+ "       Set @N=@N+1" ;
            +CR+ "       End" ;
            +CR+ "     End" ;
            +CR+ "   Set @k=@k+1" ;
            +CR+ "   End" ;
            +CR+ " Select * from #result" ;
            +CR+ " Drop Table #temp" ;
            +CR+ " Drop Table #result" ;
            +CR+ " Rollback Tran" ;
            +CR+ " End"
        *-----------------------------------------------
        = Sqlexec(m.tnSqlHandle, "if exists (select * from dbo.sysobjects" ;
            +CR+ " where id = object_id(N'[dbo].[" + m.lcTmpCursor + "]')" ;
            +CR+ " and OBJECTPROPERTY(id, N'IsProcedure') = 1)" ;
            +CR+ " drop procedure [dbo].[" + m.lcTmpCursor + "]")
        = Sqlexec(m.tnSqlHandle, m.lcMyProcedure )
        = Sqlexec(m.tnSqlHandle, "Exec " + m.lcTmpCursor + " ?tcObjectName", m.lcTmpCursor)
        = Sqlexec(m.tnSqlHandle, "if exists (select * from dbo.sysobjects" ;
            +CR+ " where id = object_id(N'[dbo].[" + m.lcTmpCursor + "]')" ;
            +CR+ " and OBJECTPROPERTY(id, N'IsProcedure') = 1)" ;
            +CR+ " drop procedure [dbo].[" + m.lcTmpCursor + "]")
        *-----------------------------------------------
        If Used(m.lcTmpCursor)
            Select (m.lcTmpCursor)
            m.lcReturn = Alltrim(ProcCode)
            Use In (m.lcTmpCursor)
        Endif
    Endif
    Return m.lcReturn
Endfunc

*-----------------------------------------------
* 函数: 获取SQL Server表脚本(创建、触发器、索引、约束)
* 设计: 红雨
* 时间: 2005.04.01
*-----------------------------------------------
Function GetTableCode( tnSqlHandle, tcDataBase, tcObjectName )
    *-----------------------------------------------
    #Define CR Chr(13)+Chr(10)
    Local lcReturn, lcTmpCursor, lcMyProcedure
    m.lcReturn = []
    m.lcTmpCursor = [T]+Sys(2015)
    m.lcDataBase = Iif(Type([m.tcDataBase])=[C] And !Empty(m.tcDataBase), m.tcDataBase, [Master])
    If Used(m.lcTmpCursor)
        Use In (m.lcTmpCursor)
    Endif
    *-----------------------------------------------
    If Type([m.tnSqlHandle])=[N] And m.tnSqlHandle>0 And Type([tcObjectName])=[C]
        = Sqlexec(m.tnSqlHandle, [use ] + m.lcDataBase )
        *-----------------------------------------------
        * 建立表的脚本
        *-----------------------------------------------
        = SQLExec(m.tnSqlhandle,[EXEC sp_MShelpcolumns N'] + m.tcObjectName + [', 512, @orderby = 'id'] , m.lcTmpCursor)
        If Used(m.lcTmpCursor)
            Select (m.lcTmpCursor)
            m.lcReturn = m.lcReturn + CR + [--- 建立表的脚本] + CR
            m.lcReturn = m.lcReturn + [If Exists (Select * From dbo.SysObjects Where id = object_id(N']+m.tcObjectName+[')] ;
                + [ and OBJECTPROPERTY(id, N'IsTable') = 1)]
            m.lcReturn = m.lcReturn + CR + [  Drop table ] + m.tcObjectName
            m.lcReturn = m.lcReturn + CR + [GO]
            m.lcReturn = m.lcReturn + CR + [Create Table ] + m.tcObjectName + [(]
            Local lTextImage
            m.lTextImage = .F.
            Scan
                m.lTextImage = m.lTextImage Or Inlist(Upper(Alltrim(Col_TypeName)),[TEXT],[NTEXT],[IMAGE])
                m.lcReturn = m.lcReturn + CR + "  [" + Alltrim(Col_Name) + "] ";
                    + "[" + Alltrim(Col_TypeName) + "]" ;
                    + Iif(Col_Flags=0, [], " (" + Iif(Isnull(Col_Prec),Alltrim(Str(Col_Len)),Alltrim(Str(Col_Prec))) ;
                    +     Iif(Isnull(Col_Scale), [], [, ] + Alltrim(Str(Col_Scale))) + ")" ) ;
                    + Iif(Isnull(Collation),[],[ Collate ] + Alltrim(Collation)) ;
                    + Iif(Col_Identity,[ Identity (1, 1)],[]) ;
                    + Iif(Col_Null, [ Null] ,[ Not Null]) + [,]
            Endscan
            m.lcReturn = Left(m.lcReturn,Len(m.lcReturn)-1) + CR + ") ON [PRIMARY]"
            m.lcReturn = m.lcReturn + Iif(m.lTextImage," TEXTIMAGE_ON [PRIMARY]",[]) + CR + [GO] + CR
            Use In (m.lcTmpCursor)
        Endif
        *-----------------------------------------------
        * 表的索引脚本
        *-----------------------------------------------
        = SQLExec(m.tnSqlhandle,[EXEC sp_MShelpindex N'] + m.tcObjectName +[' , NULL, 1] , m.lcTmpCursor)
        If Used(m.lcTmpCursor) And Reccount(m.lcTmpCursor) > 0
            Local cFieldName, nIndex
            Select (m.lcTmpCursor)
            m.lcReturn = m.lcReturn + CR + [--- 表的索引脚本] ;
                +CR+ [Create] + Iif(.F.,[ Unique],[]) + Iif(indid=1,[ Clustered],[]) ;
                +CR+ "  Index [" +Alltrim(Name)+ "] On " + m.tcObjectName +[ (]
            For m.nIndex = 1 To 16
                m.cFieldName = [IndCol]+Alltrim(Str(nIndex))
                If Isnull(Evaluate(m.cFieldName))
                    Exit
                Endif
                m.lcReturn = m.lcReturn + "[" + Alltrim(Evaluate(m.cFieldName)) + "]" ;
                    + Iif(Bitand(2^(nIndex-1),Descending) = 2^(nIndex-1), [ Desc,], [ ,])
            Endfor
            m.lcReturn = Left(m.lcReturn,Len(m.lcReturn)-1) + ") "
            m.lcReturn = m.lcReturn ;
                +CR+ [With] ;
                +CR+ [  DROP_EXISTING] ;
                +CR+ "  ON [PRIMARY]" + CR + [GO] + CR
            Use In (m.lcTmpCursor)
        Endif
        *-----------------------------------------------
        * 约束和触发器
        *-----------------------------------------------
        = Sqlexec(m.tnSqlHandle, [select Name,xType from SysObjects ] ;
            + [ where parent_obj=object_id(N']+m.tcObjectName+[') order by xType], m.lcTmpCursor)
        If Used(m.lcTmpCursor)
            Select (m.lcTmpCursor)
            Scan
                m.lcReturn = m.lcReturn + CR
                lcName = Alltrim(Name)
                Do Case
                    Case Upper(Alltrim(xType))=[TR]
                        m.lcReturn = m.lcReturn + [--- 触发器脚本: ] + lcName + CR ;
                            + GetProcedreCode( m.tnSqlHandle, m.lcDataBase, lcName )
                    Case Upper(Alltrim(xType))=[TF]
                        m.lcReturn = m.lcReturn + [--- 表函数: ] + lcName + CR ;
                            + GetProcedreCode( m.tnSqlHandle, m.lcDataBase, lcName )
                    Case Upper(Alltrim(xType))=[IF]
                        m.lcReturn = m.lcReturn + [--- 内嵌表函数: ] + lcName + CR ;
                            + GetProcedreCode( m.tnSqlHandle, m.lcDataBase, lcName )
                    Case Upper(Alltrim(xType))=[D]
                        m.lcReturn = m.lcReturn + [--- 默认值或 DEFAULT 约束: ] + lcName + CR ;
                            + [ALTER TABLE ] + m.tcObjectName + [ WITH NOCHECK ADD] + CR ;
                            + "  CONSTRAINT [" + lcName + "] DEFAULT " ;
                            + GetProcedreCode( m.tnSqlHandle, m.lcDataBase, lcName ) ;
                            + " FOR [" + Getwordnum(lcName,3,[_]) + "]"
                    Case Upper(Alltrim(xType))=[C]
                        m.lcReturn = m.lcReturn + [--- CHECK 约束: ] + lcName + CR ;
                            + [ALTER TABLE ] + m.tcObjectName + [ WITH NOCHECK ADD] + CR ;
                            + "  CONSTRAINT [" + lcName + "] CHECK " ;
                            + GetProcedreCode( m.tnSqlHandle, m.lcDataBase, lcName )
                    Case Upper(Alltrim(xType))=[F]
                        m.lcReturn = m.lcReturn + [--- FOREIGN KEY 约束: ] + lcName + CR ;
                            + [ALTER TABLE ] + m.tcObjectName + [ WITH NOCHECK ADD] + CR ;
                            + "  CONSTRAINT [" + lcName + "] FOREIGN KEY " ;
                            + GetProcedreCode( m.tnSqlHandle, m.lcDataBase, lcName )
                    Case Upper(Alltrim(xType))=[PK]
                        m.lcReturn = m.lcReturn + [--- PRIMARY KEY 约束: ] + lcName + CR ;
                            + [ALTER TABLE ] + m.tcObjectName + [ ADD] + CR ;
                            + "  CONSTRAINT [" + lcName + "] PRIMARY KEY " ;
                            + GetProcedreCode( m.tnSqlHandle, m.lcDataBase, lcName )
                    Case Upper(Alltrim(xType))=[UQ]
                        m.lcReturn = m.lcReturn + [--- UNIQUE 约束: ] + lcName + CR ;
                            + [ALTER TABLE ] + m.tcObjectName + [ ADD] + CR ;
                            + "  CONSTRAINT [" + lcName + "] UNIQUE " ;
                            + GetProcedreCode( m.tnSqlHandle, m.lcDataBase, lcName )
                    Otherwise
                Endcase
                m.lcReturn = m.lcReturn + CR + [GO] + CR
            Endscan
            Use In (m.lcTmpCursor)
        Endif
        *-----------------------------------------------
    Endif
    Return m.lcReturn
Endfunc

*-----------------------------------------------

Local lcRetuStr, lnMicLength
lcRetuStr = SendMciString( [Open ]+lcMP3File+[ Alias MICTEMP] )
If Left(lcRetuStr,5)=[错误:]
    = MessageBox(lcRetuStr, 0+16+0, [打开媒体文件错误])
Else
    = SendMciString( [Set MICTEMP Time Format MilliSeconds])    && 设置时间格式
    lnMicLength = Val(SendMciString( [Status MICTEMP Length] )) && 取媒体长度
    = SendMciString( [Close MICTEMP] )
    ? [时间: ] + allt(str(lnMicLength))+[ 毫秒]
Endif
Return

*---------------------------------------------------------------------
* 程序: 读取 MP3 信息资料
* 设计: 红雨
*---------------------------------------------------------------------
Function GetMP3Info ( tcMP3File, taMP3Info )
    External Array taMP3Info
    tcMP3File = iif(Type([tcMP3File])=[C], tcMP3File, [])
    If Type([aLen(taMP3Info,1)])#[N]
        Dime taMP3Info(5)
    Else
        If aLen(taMP3Info,1)#5
            Dime taMP3Info(5)
        Endif
    Endif
    If File(tcMP3File)
        Local lcMP3Str, lnFHand
        lnFHand = FOPEN( tcMP3File )
        If lnFHand > 0
            = FSEEK( lnFHand, -128, 2)
            lcMP3Str = FREAD( lnFHand, 127 )
            = FCLOSE( lnFHand )
            If uppe(subs(lcMP3Str,1,3)) = [TAG]
                lcMP3Str = subs(lcMP3Str,4)
                taMP3Info(1) = allt(subs(lcMP3Str, 1,30))+chr(0)
                taMP3Info(1) = allt( left(taMP3Info(1),at(chr(0),taMP3Info(1))-1) )
                taMP3Info(2) = allt(subs(lcMP3Str,31,30))+chr(0)
                taMP3Info(2) = allt( left(taMP3Info(2),at(chr(0),taMP3Info(2))-1) )
                taMP3Info(3) = allt(subs(lcMP3Str,61,30))+chr(0)
                taMP3Info(3) = allt( left(taMP3Info(3),at(chr(0),taMP3Info(3))-1) )
                taMP3Info(4) = allt(subs(lcMP3Str,91, 4))+chr(0)
                taMP3Info(4) = allt( left(taMP3Info(4),at(chr(0),taMP3Info(4))-1) )
                taMP3Info(5) = allt(subs(lcMP3Str,95,30))+chr(0)
                taMP3Info(5) = allt( left(taMP3Info(5),at(chr(0),taMP3Info(5))-1) )
                Return .T.
            Else
                Return .F.
            Endif
        Else
            Return .F.
        Endif
    Else
        Return .F.
    Endif
Endfunc

Function SendMciString( tcMCIcmd )
    Declare integer mciSendString in WINMM String, String, integer,integer
    Declare integer mciGetErrorString in WINMM integer, String, integer
    lcRetStr = Space( 80)
    lcErrStr = Space(256)
    lnRetVal = mciSendString( tcMCIcmd, @lcRetStr, Len(lcRetStr), 0 )
    If lnRetVal=0
        Retu Trim(Strtran(lcRetStr,chr(0),""))
    Else
        = mciGetErrorString(lnRetVal,@lcErrStr,Len(lcErrStr))
        Retu [错误: ]+Trim(Chrtran(lcErrStr,chr(0),""))
    Endif
Endfunc