sypos.sra

这是用PB6开发的一个POS管理系统

$PBExportHeader$sypos.sra
forward
global transaction sqlca
global dynamicdescriptionarea sqlda
global dynamicstagingarea sqlsa
global error error
global message message
end forward

type stru_time from structure
	integer		Year
	integer		Month
	integer		DayofWeek
	integer		Day
	integer		Hour
	integer		Minute
	integer		Second
	integer		MilliSecond
end type

global variables
string gs_DeptNo
string gs_Operator
string gs_OperatorName
boolean gb_LessthanZero  //库存是否允许小于零 
boolean gb_alldepart
boolean gb_demo  // is a demo version
string gs_dir
long   gl_grade
boolean gb_Audit  //true :  需要审核  false:不需要审核

// for checks
string gs_dwmc
end variables

global type sypos from application
 end type
global sypos sypos

type prototypes
Function Boolean SetLocalTime(stru_time stime) Library "kernel32.dll"
Function Boolean SetSystemTime(stru_time stime) Library "kernel32.DLL"
Function ulong FindWindowA (ulong classname, string windowname) Library "USER32.DLL"
Function boolean  CopyFileA(string lpExistingFileName,string lpNewFileName,boolean bFailIfExists) Library "KERNEL32.DLL"	
Function uint GetSystemDirectoryA (ref string dirtext, uint textlen) library "KERNEL32.DLL"
Function ulong GetCurrentDirectoryA (ulong textlen, ref string dirtext) library "KERNEL32.DLL"
Function Long WNetAddConnectionA(string path,String pwd,string drv) Library "mpr.dll"
Function Long Encrypt(string temp,long len) Library "pass.dll"
Function Boolean GetComputerNameA(ref string name,ref long len) Library "kernel32.dll"
function int OpenBox(string file,string msg) Library "Messagebox.dll"
function int DelBox() Library "MessageBox.dll"

//================================================================
// Function:  GETFONTHEX()  in FNTHEX32.DLL
// Purpose:   Get bitmap in hex code of specific out string and font to buffer.
// Parameters:
//       1) LPSTR outStr,                    // output string
//       2) LPSTR lfFaceName,          // Windows font name
//       3) short int lfOrientation,          // clock-wish Orientation: 0,90,180,270
//       4) short int lfHeight,                // font height
//       5) short int lfWidth,                 // font width, always set to 0
//       6) short int lfBold,                   // bold font style
//       7) short int lfItalic,                  // italic font style
//       8) LPSTR hexBuf                  // buffer to receive hex codes, must be passed as reference
//                                                         and space size must be set to 21K.
// Return : Byte count of buffer contents if successful, otherwise <= 0
// Note : 1) Before program to call function GETFONTHEX() in FNTHEX32.DLL,
//               Statement must be added to declare it in the call program.
//           2) Function name GETFONTHEX() must in upper case.
//           3) Before function GETFONTHEX() is called, the buffer that is equal
//               to 21K must to allocate first.
//           4) The return of GETFONTHEX() is greate than 0 if function call is
//               successful, and result of Chinese data is stored in 21K buffer.
//               The total number of byte output in buffer is return by GETNFONTHEX()
//           5) Printer driver "Generic / Text Only" must be set for
//               label printing under Windows 32 bit environment.
//================================================================
function int GETFONTHEX(string outstr, string fontname,  int orient, int height,  int width,  int bold, int italic, ref string hexbuf) library "fnthex32.dll" 

end prototypes

type variables
datetime id_localtime
end variables

forward prototypes
public subroutine settoservertime ()
public subroutine connecttobase (string as_base)
public subroutine connecttoyear (string as_base)
public subroutine getsystemparams ()
end prototypes

public subroutine settoservertime ();datetime ld_ServerTime
stru_time lst_time

select Getdate() into :ld_ServerTime from sysobjects;

lst_time.Year=Year(Date(ld_ServerTime))
lst_time.Month=Month(Date(ld_ServerTime))
lst_time.Day=Day(Date(ld_ServerTime))
lst_time.Hour=Hour(Time(ld_ServerTime))
lst_time.Minute=Minute(Time(ld_ServerTime))
lst_time.Second=Second(Time(ld_ServerTime))
lst_time.MilliSecond=5
SetLocalTime(lst_time)
end subroutine

public subroutine connecttobase (string as_base);string ls_name
long len

ls_name=space(30)
len=30
GetComputerNameA(ref ls_name,ref len)

sqlca.DBMS       = ProfileString ("sypos.ini", "database", "dbms",       "MSS Microsoft SQL Server 6.x")
sqlca.database   = as_Base
sqlca.userid     = ProfileString ("sypos.ini", "database", "userid",     "")
sqlca.dbpass     = ProfileString ("sypos.ini", "database", "dbpass",     "")
sqlca.logid      = ProfileString ("sypos.ini", "database", "logid",      'sypos')
sqlca.logpass    = ProfileString ("sypos.ini", "database", "LogPassWord", '')
sqlca.servername = ProfileString ("sypos.ini", "database", "servername", 'bzp')
sqlca.dbparm     = ProfileString ("sypos.ini", "database", "dbparm",     "host='" + ls_name+ "'")
sqlca.lock='RC'
sqlca.AutoCommit = false

connect;

if sqlca.sqlcode <> 0 then
	MessageBox ("提示","连接数据库失败",StopSign!)
	f_write_sqlerrlog()
	halt
end if



end subroutine

public subroutine connecttoyear (string as_base);string ls_date
string ls_database
int li_count,li_year
string ls_change

ls_date=string(today(),'yyyymmdd')
select year into :li_year from months where 
convert(char(8),enddate,112) >= :ls_date and convert(char(8),startdate,112) <= :ls_date;
if sqlca.sqlcode < 0 then
	MessageBox ("提示","没有设置结算日期",StopSign!)
	f_write_sqlerrlog()
	halt
elseif sqlca.sqlcode=100 then
	MessageBox ("提示","请先设置结算日期",StopSign!)
	open(w_base_acctdate_Input)
	halt
end if

ls_change='0'
select isnull(value,'0') into :ls_change from sysparams where name='year';
if ls_change='0' then
	ls_database=as_base + '2000'
else
	ls_database=as_Base + string(li_year)
	select count(*) into :li_count from sysdatabases where name=:ls_database;
	if li_count < 1 then
		halt
	end if
end if
disconnect;
sqlca.database=ls_database

connect;
if sqlca.sqlcode <> 0 then
	MessageBox ("提示","连接数据库失败",StopSign!)
	f_write_sqlerrlog()
	halt
end if

end subroutine

public subroutine getsystemparams ();if gf_GetSysparams('audit')='1' then
	gb_Audit = true
else
	gb_audit = false
end if

if gf_GetSysparams('lessthanzero')='1' then
	gb_LessThanZero=true
else
	gb_LessthanZero=false
end if

gs_dir=space(40)
GetcurrentdirectoryA(40,gs_dir)
gs_dir=trim(gs_dir)
end subroutine

on sypos.create
appname = "sypos"
message = create message
sqlca = create transaction
sqlda = create dynamicdescriptionarea
sqlsa = create dynamicstagingarea
error = create error
end on

on sypos.destroy
destroy( sqlca )
destroy( sqlda )
destroy( sqlsa )
destroy( error )
destroy( message )
end on

event open;string ls_title,ls_database,ls_liblist
int ver
	
	
ls_liblist=Profilestring('sypos.ini','sypos','liblist','')
this.SetLibraryList(ls_liblist)

open(w_mdi_frame)
open(w_status)
w_mdi_frame.PostEvent(Resize!)

ls_title=ProfileString ("sypos.ini", "sypos", "title",     "")
ver=ProfileInt("sypos.ini","sypos","ver",1)
choose case ver
	case 2
		ls_title = ls_title + '___配货中心系统'
	case 3
		ls_title = ls_title + '___门店系统'
	case 1
		ls_title = ls_title + '___总部系统'
end choose
w_mdi_frame.Title=ls_title

if profileint('sypos.ini','sypos','toolbartext',1)=1 then this.toolbartext=true

ls_database = ProfileString ("sypos.ini", "database", "database",    "sypos")

ConnectToBase(ls_database)

SetToServerTime()

ConnectToYear(ls_database)

GetSystemParams()

if fileexists(gs_dir + "\script\upgrade.sql") then open(w_main_upgrade)

open(w_main_login)
open(w_funcs_select)





end event

event systemerror;string errtext

errtext='对象:' + error.object + '~r事件:' + error.objectevent &
+ '~r行号:' + string(error.line) + '~r号码:' + string(error.number) &
+ '~r提示:' + error.text
messagebox("提示",errtext)
f_write_log(errtext)
rollback;
disconnect;
halt;

end event

event close;disconnect;
end event