Место общения программистов, форум разработчиков БД на Clarion
https://forum.clarionlife.net/
Код: Выделить всё
program
DWORD EQUATE(ULONG)
HANDLE EQUATE(UNSIGNED)
WORD EQUATE(SIGNED)
LPCSTR EQUATE(CSTRING)
MAP
module('ODBC32.lib')
! proc - все равно как вызывать - процедура \ функция
! ВСе прототипы из MS SDK ODBC
SQLAllocHandle(SHORT, LONG, *LONG), SHORT, RAW, PASCAL, NAME('SQLAllocHandle'),proc,DLL(1)
SQLSetEnvAttr(LONG, LONG, LONG , LONG), SHORT, RAW, PASCAL, NAME('SQLSetEnvAttr'),proc,DLL(1)
SQLConnect(LONG, *CSTRING, SHORT, *CSTRING, SHORT, *CSTRING, SHORT), SHORT, RAW, PASCAL, NAME('SQLCONNECT'),proc,DLL(1)
SQLEXECDirect(LONG, *CSTRING, LONG), SHORT, RAW, PASCAL, NAME('SQLEXECDIRECT'),proc,DLL(1)
SQLPrepare(LONG, *CSTRING, LONG), SHORT, RAW, PASCAL, NAME('SQLPREPARE'), proc, DLL(1)
SQLBindParameter(LONG,USHORT,SHORT, SHORT, SHORT, ULONG, SHORT, *?, LONG, *? ),SHORT,RAW,PASCAL,NAME('SQLBindParameter'),proc,DLL(1)
SQLExecute(LONG), SHORT ,RAW, PASCAL, NAME('SQLEXECUTE'), PROC, DLL(1)
SQLBindCol(LONG, USHORT, SHORT, LONG, LONG ,LONG),SHORT,RAW,PASCAL,NAME('SQLBINDCOL'),proc,DLL(1)
SQLNumResultCols(LONG, *SHORT), SHORT, RAW, PASCAL, NAME('SQLNUMRESULTCOLS'),proc,DLL(1)
SQLFetch(LONG), SHORT, RAW, PASCAL, NAME('SQLFETCH'),proc,DLL(1)
SQLColAttribute(LONG, USHORT, USHORT, LONG, SHORT, *SHORT, *LONG), SHORT, RAW, PASCAL, NAME('SQLCOLATTRIBUTE'),proc,DLL(1)
SQLDescribeCol(LONG, USHORT, *CSTRING, SHORT, *SHORT, *SHORT, *ULONG, *SHORT, *SHORT), SHORT, RAW, PASCAL, NAME('SQLDESCRIBECOL'),proc,DLL(1)
SQLColAttributes(LONG, USHORT, USHORT, LONG, SHORT, *SHORT, *LONG), SHORT, RAW, PASCAL, NAME('SQLCOLATTRIBUTES'),proc,DLL(1)
SQLCloseCursor(LONG),SHORT, RAW, PASCAL, NAME('SQLCloseCursor'),proc,DLL(1)
SQLFreeHandle(SHORT, LONG),SHORT, RAW, PASCAL, NAME('SQLFreeHandle'),proc,DLL(1)
SQLDisconnect(LONG),SHORT,RAW,PASCAL,NAME('SQLDISCONNECT'),proc,DLL(1)
end
! и еще
SelectFB(string, string , string, *string , *string ), long !URL POST Data Server Data
end
dsn string(32)
uid string(32)
pwd string(32)
req string(255)
rez string(528000)
Window WINDOW('Firebird ODBC Access'),AT(,,395,264),FONT('MS Sans Serif',8,,FONT:regular),CENTER,GRAY
TEXT,AT(12,7,373,187),USE(rez),BOXED,HVSCROLL
BUTTON('Lookup'),AT(269,214,33,14),USE(?lookup)
BUTTON('Exit'),AT(311,214,33,14),USE(?OkButton),LEFT,DEFAULT
ENTRY(@s32),AT(11,215,191,10),USE(dsn)
ENTRY(@s32),AT(11,228,191,10),USE(uid)
ENTRY(@s100),AT(11,202,191,10),USE(pwd)
ENTRY(@s100),AT(12,242,376,10),USE(req)
END
code
!
! this code is only executed if linked as an .exe
!
dsn = 'FireBird'
uid = 'SYSDBA'
pwd = 'masterkey'
req = 'select * from Country'
open (window)
accept
! if event() = event:openwindow then
! rtn# = postadata(serv,pexe,bff,text1)
! if rtn# <> 0 then message('It didnt work - ' & rtn#,'Error',icon:exclamation).
! end
if accepted() = ?okbutton then break.
if accepted() = ?lookup then
clear(rez)
rtn# = SelectFB(dsn,uid,pwd,req,rez)
if rtn# <> 0 then
message('It didnt work - ' & rtn#,'Error',icon:exclamation)
end
display()
end
end ! accept loop
!----------------------------------------------------------------------------------------
SelectFB Procedure(string pstdsn, string pstuid, string pstpwd, *string pstreq, *string pstrez)
!----------------------------------------------------------------------------------------
Include('ODBC_EQU.INC')
ZERO DWORD
henv handle
hdbc handle
hstmt handle
s0 long
s1 long
s2 long
doplong long
buffpointer long
bufflen long
FldBindType short
buff cstring(255),DIM(30)
szuser cstring(32)
szpass cstring(32)
szdsn cstring(32)
serchs cstring(255)
qcols short
code
henv = 0
! Alloc env handle
if SQLAllocHandle(SQL_HANDLE_ENV, 0, henv) <> 0 then
message('AllocHandle on ENV failed.')
else ! 1
! message('AllocHandle on ENV OK.')
SQLSetEnvAttr(henv, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC3, SQL_IS_INTEGER)
hdbc = 0
if SQLAllocHandle(SQL_HANDLE_DBC, henv, hdbc) <> 0 then
message('AllocHandle on DBC failed.')
else ! 2
! message('AllocHandle on DBC OK.')
szDsn = clip(pstdsn)
szuser = clip(pstuid)
szPass = clip(pstpwd)
if SQLConnect(hdbc,szDsn, len(szdsn), szuser, len(szUser), szPass, len(szPass)) <> 0 then
message('Connect to ODBC failed.')
else ! 3
! message('Connect to ODBC OK.')
! Get a statement handle
if SQLAllocHandle(SQL_HANDLE_STMT, hdbc, hstmt) <> 0 then
message('AllocHandle on STMT failed.')
else ! 4
! message('AllocHandle on STMT OK.')
! Подготавливаем запрос, обратите внимание на знаки "?" вместо значений.
serchs = clip(pstreq)
s0 = SQLPrepare(hstmt, serchs, len(serchs))
if s0 <> 0 then
message('SQLPrepare on STMT failed.')
end
! Связываем 1-й и 2-й параметры с переменными.
! SQLBindParameter(hstmt, 1, SQL_PARAM_INPUT, SQL_C_FLOAT, SQL_REAL, 7, 0, Price, 0, &PriceInd);
! SQLBindParameter(hstmt, 2, SQL_PARAM_INPUT, SQL_C_ULONG, SQL_INTEGER, 10, 0, PartID, 0, PartIDInd);
! Запрос готов.
! Инициализируем связанные переменные значениями и выполняем запрос.
! while (GetPrice(&PartID, &Price))
!
s0 = SQLExecute(hstmt)
if s0 <> 0 then
message('SQLExecute on STMT failed.')
end
s0 = SQLNumResultCols( hstmt, QCols )
if s0 <> 0 then
message('SQLNumResultCols on STMT failed.')
end
if Qcols > 30 then qcols = 30 .
loop s2 = 1 to Qcols
bufflen = 255
s0 = SQLBindCol( hstmt, s2, SQL_C_CHAR , Address(buff[s2]), BuffLen, doplong )
if s0 <> 0 then
message('SQLBindCol on STMT failed.')
end
end
! if s0 <> 0 then
! message('SQLBindCol on STMT failed.')
! end
loop
s0 = SQLFetch(hstmt)
! if s0 <> 0 then
! message('SQLFetch on STMT failed.')
! end
if s0 = SQL_NO_DATA then break .
loop s1 = 1 to qcols
pstrez = clip(pstrez) & clip(buff[s1]) & '|'
end
pstrez = clip(pstrez) & '<13><10>'
end
if hstmt <> 0 then SQLFreeHandle(SQL_HANDLE_STMT, hstmt) .
if hdbc <> 0 then SQLDisconnect(hdbc); SQLFreeHandle(SQL_HANDLE_DBC, hdbc) .
if henv <> 0 then SQLFreeHandle(SQL_HANDLE_ENV, henv) .
end
end
end
end
return(0)Код: Выделить всё
program
DWORD EQUATE(ULONG)
HANDLE EQUATE(UNSIGNED)
WORD EQUATE(SIGNED)
LPCSTR EQUATE(CSTRING)
MAP
module('wininet.lib') ! Найди и сделай сам
InternetOpen(*lpcstr,dword,*lpcstr,dword,dword),handle,pascal,raw,NAME('InternetOpenA'),dll(1)
InternetOpenURL(handle,*lpcstr,dword,dword,dword,dword),handle,pascal,raw,name('InternetOpenURLA'),dll(1)
InternetReadFile(handle,*lpcstr,dword,*dword),handle,pascal,raw,name('InternetReadFile'),dll(1)
InternetCloseHandle(handle),pascal,raw,name('InternetCloseHandle'),dll(1)
InternetConnect(handle,*lpcstr,dword,*lpcstr,*lpcstr,dword,dword,dword),handle,pascal,raw,NAME('InternetConnectA'),dll(1)
HttpOpenRequest(handle,*lpcstr,*lpcstr,*lpcstr,*lpcstr,dword,dword,dword),handle,pascal,raw,name('HttpOpenRequestA'),dll(1)
HttpSendRequest(handle,*lpcstr,dword,*lpcstr,dword),handle,pascal,raw,name('HttpSendRequestA'),dll(1)
end
! и еще единственная процедура - необременительно
Postadata(string pstserv, string pstexe, *string pstarea, *string pTextBuf), long !URL POST Data Server Data
end
serv string(250) ! Сервер http://www.nechto.com
pexe string(250) ! CGI or PHP nechto.exe
bff string(64000) ! Post data in structure &p1=123&p2=rtr...&pn=4
text1 string(528000) ! In data - maybe %20 and so on. Clearing need.
Window WINDOW('Fetch a Web Page'),AT(,,395,241),FONT('MS Sans Serif',8,,FONT:regular),CENTER,GRAY
TEXT,AT(12,7,373,187),USE(Text1),BOXED,HVSCROLL
BUTTON('Lookup'),AT(269,214,33,14),USE(?lookup)
BUTTON('Exit'),AT(311,214,33,14),USE(?OkButton),LEFT,DEFAULT
ENTRY(@s100),AT(11,215,191,10),USE(pexe)
ENTRY(@s100),AT(11,228,191,10),USE(bff)
ENTRY(@s100),AT(11,202,191,10),USE(serv)
END
code
! this code is only executed if linked as an .exe
serv = 'localhost'
pexe = 'shell.exe?L'
bff = '&a=2222&b=1111'
open (window)
accept
! if event() = event:openwindow then
! rtn# = postadata(serv,pexe,bff,text1)
! if rtn# <> 0 then message('It didnt work - ' & rtn#,'Error',icon:exclamation).
! end
if accepted() = ?okbutton then break.
if accepted() = ?lookup then
clear(text1)
rtn# = postadata(serv,pexe,bff,text1)
if rtn# <> 0 then
message('It didnt work - ' & rtn#,'Error',icon:exclamation)
else
message('Ok - ' & rtn#,'Error',icon:exclamation)
end
display()
end
end ! accept loop
!----------------------------------------------------------------------------------------
PostaData Procedure(string pstserv, string pstexe, *string pstarea, *string pTextBuf)
!----------------------------------------------------------------------------------------
! InternetOpen Сессия
! InternetConnect Коннект
! HttpOpenRequest Запрос
! HttpSendRequest Послать
! InternetReadFile Получить
! InternetCloseHandle Закрыть запрос
! InternetCloseHandle Закрыть коннект
! InternetCloseHandle Закрыть сессию
!----------------------------------------------------------------------------------------
UserAgent cstring('Mozilla/4.0 (compatible; MSIE 6.0b; Windows NT 5.0; .NET CLR 1.0.2914)')
ProxyName CSTRING(1000)
OpenType dword
bufferlen equate(528001)
HTTPbuffer cstring(bufferlen)
Headerlen Dword
Headerbuf cstring(250),AUTO ! Content-Type: application/x-www-form-urlencoded
Postlen Dword
postbuf cstring(64000),AUTO ! name=Andrew+Art&userid=hithere&other=P%26Q
bytesread dword
! Open Flags
INTERNET_OPEN_TYPE_PRECONFIG EQUATE(0) !- use registry configuration
INTERNET_OPEN_TYPE_DIRECT EQUATE(1) !- direct to net
INTERNET_OPEN_TYPE_PROXY EQUATE(3) !- via named proxy
!OpenURL dwFlags
INTERNET_FLAG_NO_CACHE_WRITE EQUATE(04000000H) ! Does not add the returned entity to the cache.
INTERNET_FLAG_RELOAD equate(80000000H) ! Forces a download of the requested file, object,
! or directory listing from the origin server, not from the cache.
INTERNET_FLAG_PRAGMA_NOCACHE equate(00000100H) ! Forces the request to be resolved by the origin server,
! even if a cached copy exists on the proxy.
NoCaching equate(84000100H) ! all of the above
INTERNET_DEFAULT_HTTP_PORT equate(00000050H) ! Номер TCP/IP порта к которому мы собираемся подсоединиться
INTERNET_SERVICE_HTTP equate(00000003H) ! Тип сервиса - FTP, HTTP или Gopher
ZERO DWORD
hsession handle
hconnect handle
hrequest Handle
hReadFile handle
hsend handle
dwFlags dword
dwContext dword
postserv cstring(250),AUTO
postexe cstring(250),AUTO
pTextBufLen long
Pageptr long
ReturnCode long
usid cstring(20)
psw cstring(20)
postv cstring(20)
acc dword
version cstring(20)
reff cstring(20)
s0 long
code
postv = 'POST'
Headerbuf = 'Content-Type: application/x-www-form-urlencoded' & '<0>'
headerlen = len(Headerbuf)
postserv = clip(pstserv) & '<0>'
postexe = clip(pstexe) & '<0>'
! loop s0 = 1 to 8000
! if pstarea[s0] = ' ' then break .
! postbuf[s0] = pstarea[s0]
! end
! postbuf[s0] = '<0>'
postbuf = CLIP(PSTAREA) & '<0>'
postlen = len(postbuf)
pTextBufLen = len(pTextBuf)
OpenType = INTERNET_OPEN_TYPE_PRECONFIG
ReturnCode = 0
version = 'HTTP/1.1<0>'
reff = 'http://s775/rocom.exe<0>'
usid = 'anonymous<0>'
psw = '<0>'
hsession = InternetOpen(UserAgent,OpenType,ProxyName,zero,zero)
if hsession = 0 then
ReturnCode = 1 !* Error * Internet Open error
else
dwFlags = NoCaching
hconnect = InternetConnect(hsession,postserv,INTERNET_DEFAULT_HTTP_PORT, usid, psw, INTERNET_SERVICE_HTTP, dwFlags, dwContext)
if hconnect = 0 then
ReturnCode = 2 !* Error * Internet Connect error
else
hrequest = HttpOpenRequest(hConnect, postv, postexe, version, reff, 0, dwFlags, dwContext);
if hrequest = 0 then
ReturnCode = 3 !* Error * Internet Request error
else
hsend = HttpSendRequest(hRequest, headerbuf, headerlen, postbuf, postlen)
if hsend = false then
ReturnCode = 4 !* Error * Internet send error
else
Pageptr = 1
loop
hReadFile = InternetReadFile(hRequest,HTTPbuffer,bufferlen-1,bytesread)
if hReadFile = true and bytesread = 0 then break.
if bytesread > 0 then
if Pageptr + bytesread > pTextBuflen then
Returncode = 5 ! * Error * Buffer size exceeded
break
end
pTextBuf = pTextBuf[1:Pageptr] & HTTPbuffer[1:bytesread] ! + first byte always _
Pageptr += bytesread
end
end
end
end
end
end
internetclosehandle(hrequest)
internetclosehandle(hconnect)
internetclosehandle(hsession)
return(ReturnCode)Код: Выделить всё
sp = len(clip(GP))
s0 = Instring('=',gp,1,1) ! символ = используется как разделитель полей
gp[1:(sp)] = clip(gp[(s0+1):(sp)])
sp = len(clip(GP))
loop s0 = 1 to sp
strv = gp[s0]
if strv = '%' then
gp[s0] = CHR( |
Instring(gp[s0+1],'0123456789ABCDEF',1,1)*16 + |
Instring(gp[s0+2],'0123456789ABCDEF',1,1) - 17 )
gp[(s0+1):(sp)] = clip(gp[(s0+3):(sp)])
end
if strv = '<10>' then
gp[(s0):sp] = clip(gp[(s0+1):sp])
end
if strv = '<13>' then
gp[(s0):sp] = clip(gp[(s0+1):sp])
end
endКод: Выделить всё
sp = len(clip(GP))
s0 = Instring('=',gp,1,1) ! символ = используется как разделитель полей
gp[1:(sp)] = clip(gp[(s0+1):(sp)])
sp = len(clip(GP))
loop s0 = 1 to sp
strv = gp[s0]
if strv = '%' then
gp[s0] = CHR( |
Instring(gp[s0+1],'0123456789ABCDEF',1,1)*16 + |
Instring(gp[s0+2],'0123456789ABCDEF',1,1) - 17 )
gp[(s0+1):(sp)] = clip(gp[(s0+3):(sp)])
end
if strv = '<10>' then
gp[(s0):sp] = clip(gp[(s0+1):sp])
end
if strv = '<13>' then
gp[(s0):sp] = clip(gp[(s0+1):sp])
end
endКод: Выделить всё
if strv = '<13>'
gp[(s0):sp] = clip(gp[(s0+1):sp])
end