I try to insert into blob field in SQLite with Delphi XE3.
I've been using TDBXCommand and TSQLConnection like this.
but blob field is not inserted and even i cannnot get any result from query
procedure TDBXCommandHelper.Init(const AQry: String);
begin
Parameters.ClearParameters;
Close;
Prepare;
Text := AQry;
end;
procedure dmDB.InsertPicture;
const
QRY = 'INSERT INTO Memo(Picture) VALUES(?)';
var
LTransaction: TDBXTransaction;
LBlob: TDBXParameter;
LStream: TFileStream;
begin
LTransaction := FDBCon.BeginTransaction;
LStream := TFileStream.Create('d:\sample.bmp', fmOpenRead);
LBlob := TDBXParameter.Create;
try
try
FDBXCmd := FDBCon.DBXConnection.CreateCommand;
FDBXCmd.CommandType := TDBXCommandTypes.DbxSQL;
FDBXCmd.Init(QRY);
LBlob.DataType := TDBXDataTypes.BlobType;
LBlob.SubType := TDBXSubDataTypes.BinarySubType;
LBlob.Value.SetStream(LStream, False);
FDBXCmd.Parameters.AddParameter(LBlob);
FDBXCmd.ExecuteUpdate;
except
on E: Exception do
FDBCon.RollbackFreeAndNil(LTransaction);
end;
FDBCon.CommitFreeAndNil(LTransaction);
finally
FreeAndNil(LStream);
FreeAndNil(LBlob);
end;
end;
using TSQLConnection but i cannot get any result
procedure TInsertThread.NoteInsertExcute;
const
QRY = 'INSERT INTO Memo(Picture) VALUES(:Picture)';
var
LTransaction: TDBXTransaction;
LParams: TParams;
LStream: TMemoryStream;
begin
LTransaction := FDBCon.BeginTransaction;
LParams := TParams.Create(nil);
LStream := TMemoryStream.Create;
LStream.LoadFromFile(FValues.Values[NAME_PICTURE]);
try
LParams.CreateParam(ftBlob, 'Picture', ptInput);
LParams.ParamByName('Picture').LoadFromStream(LStream, ftBlob);
FDBCon.Execute(QRY, LParams);
FDBCon.CommitFreeAndNil(LTransaction);
finally
FreeAndNil(LStream);
FreeAndNil(LParams);
end;
end;
That's easy like:
var
ms: TMemoryStream;
sq: TSQLQuery;
begin
ms := TMemoryStream.Create;
ms.LoadFromFile('C:\Pictures\l.jpg');
if ms <> nil then
begin
sq := TSQLQuery.Create(nil);
sq.SQLConnection := con1;
sq.SQL.Text := 'update db1 set picture= :photo ;';
sq.Params.ParseSQL(sq.SQL.Text, true);
sq.Params.ParamByName('photo').LoadFromStream(ms, ftBlob);
sq.ExecSQL();
end;
.
Where con1 is a TSQLConnection.
You can try the following:
function GetFileAsBytesValue(AFileName: TFileName): TArray<Byte>;
var
Len: Integer;
LStream: TMemoryStream;
begin
LStream := TMemoryStream.Create;
try
LStream.LoadFromFile(AFileName);
Len := LStream.Size;
SetLength(Result, Len);
Move(LStream.Memory^, Result[0], Len);
finally
LStream.Free;
end;
end;
procedure dmDB.InsertPicture;
const
QRY = 'INSERT INTO Memo(Picture) VALUES(?)';
var
LTransaction: TDBXTransaction;
LDBXCmd: TSQLQuery;
LParam: TParam;
begin
LTransaction := FDBCon.BeginTransaction;
LDBXCmd := TSQLQuery.Create(FDBCon);
try
try
LDBXCmd.SQLConnection := FDBCon;
LDBXCmd.SQL.Text := QRY;
LParam := LDBXCmd.Params.CreateParam(ftBlob, 'Picture', ptInput);
LParam.AsBlob := GetFileAsBytesValue('d:\sample.bmp');
LDBXCmd.ExecSQL;
except
on E: Exception do
FDBCon.RollbackFreeAndNil(LTransaction);
end;
FDBCon.CommitFreeAndNil(LTransaction);
finally
LDBXCmd.Free;
end;
end;
Related
I am trying to send a TStringStream from client to server, then send it back from server to client, using Indy TCP components.
Here is my client code:
var
Jpg: TJPEGImage;
StringStream: TStringStream;
strcams, StringImageData: String;
byt, i: integer;
procedure SendCommandWithParams(Command, Params: String);
begin
Lock;
try
if not FTCP.Connected then
begin
exit;
end;
FTCP.Socket.WriteLn('1' + Command, IndyTextEncoding_UTF8);
FTCP.Socket.WriteLn(Params, IndyTextEncoding_UTF8);
finally
Unlock;
end;
end;
begin
Jpg := TJPEGImage.Create;
StringStream := TStringStream.Create('');
try
try
Jpg.Performance := jpBestSpeed;
Jpg.ProgressiveEncoding := True;
Jpg.ProgressiveDisplay := True;
Jpg.Assign(Image2.Picture.Bitmap);
Jpg.CompressionQuality := 25;
Jpg.Compress;
Jpg.SaveToStream(StringStream);
StringImageData := StringStream.DataString;
strcams := '<[S:' + IntToStr(Length(StringImageData)) + 'B]>' +
StringImageData;
if Length(strcams) < byt then
begin
SendCommandWithParams('SIMGSEND', strcams + sep + 'IMGID5423' + sep);
end;
except
on e: exception do
//
end;
finally
StringImageData := '';
FreeAndNil(Jpg);
FreeAndNil(StringStream);
end;
end;
I can receive the TStringStream data, but the data received is corrupted, and some times it gets replaced with the second parameter that I send which is 'IMGID5423' + sep. I am not sure if this is because of some limit of packet sending through TCP so the data does not arrive complete, or is this a parser issue?
My current parser should separate each text that ended with #13#10. Here is how it looks:
var
ReceiveParams, ReceiveStream: Boolean;
S: string;
Command: String;
begin
Command := Fholdcommand;
ReceiveParams := false;
ReceiveStream := false;
if Command[1] = '1' then // command with params
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := True;
end;
if ReceiveParams then // params incomming
begin
S := FTCP.Socket.ReadLn(IndyTextEncoding_UTF8);
FCMD := Command;
FPRMS := S;
FSTREAM := false;
if Assigned(FOnCallbackProc) then
begin
Synchronize(DoCallbackProc);
end;
end;
I am still confused about the real issue. I try to send the TStringStream in a local procedure, and it is received normally without any corruption.
Am I sending the data wrong altogether through Indy?
This is how I am receiving the data:
procedure CreateJpg(Data:string);
var
StringStream : TStringStream;
JpegImage : TJPEGImage;
Bitmap : TBitmap;
tmpPos:integer;
pp:string;
label check;
begin
GData := Data;
if LeftStr(GData,4) = '<[S:' then
begin
tmpPos := Pos(WideString('B]>'),GData);
pp := Copy(GData,5,tmpPos-5);
CDataELen := StrToInt(pp); //MidStr(st,5,tmppos - 5);
CData := RightStr(GData,length(GData)-(tmppos+2));
goto check;
end;
CData := CData + GData;
check:
//if CDataELen = length(CData) then
begin
StringStream := TStringStream.Create('');
JpegImage := TJpegImage.Create;
StringStream.WriteString(CData);
CData := '';
try
try
StringStream.Seek(0, soFromBeginning);
JpegImage.LoadFromStream(StringStream);
Bitmap := TBitmap.Create;
with Bitmap do
begin
Canvas.Lock;
try
Width := JpegImage.Width;
Height := JpegImage.Height;
Canvas.Draw(0, 0, JpegImage);
finally
Canvas.Unlock;
end;
end;
img.Picture.Bitmap.Width := Bitmap.Width;
img.Picture.Bitmap.Height := Bitmap.Height;
img.Picture.Bitmap.Canvas.Draw(0, 0, Bitmap);
except
on E: Exception do
//
end;
finally
FreeAndNil(StringStream);
FreeAndNil(JpegImage);
FreeAndNil(Bitmap);
end;
end;
end;
The problem is that you are saving the JPG binary data to a TStringStream and then letting it reinterpret the binary data as if it were string data. You can't do that. You need to save the JPG data to a binary stream instead, like TMemoryStream, and then encode the binary data using a string-safe encoding, like Base64.
Try something more like this instead:
uses
..., IdCoder, IdCoderMIME;
...
var
Jpg: TJPEGImage;
JpegStream: TMemoryStream;
strcams, StringImageData: String;
begin
try
JpegStream := TMemoryStream.Create;
try
Jpg := TJPEGImage.Create;
try
Jpg.Performance := jpBestSpeed;
Jpg.ProgressiveEncoding := True;
Jpg.ProgressiveDisplay := True;
Jpg.Assign(Image2.Picture.Bitmap);
Jpg.CompressionQuality := 25;
Jpg.Compress;
Jpg.SaveToStream(JpegStream);
finally
Jpg.Free;
end;
JpegStream.Position := 0;
StringImageData := TIdEncoderMIME.EncodeStream(JpegStream);
finally
JpegStream.Free;
end;
strcams := '<[S:' + IntToStr(Length(StringImageData)) + 'B]>' + StringImageData;
SendCommandWithParams('SIMGSEND', strcams + sep + 'IMGID5423' + sep);
except
on e: exception do
//
end;
end;
And then on the receiving end:
procedure CreateJpg(Data: string);
var
JpegStream: TMemoryStream;
JpegImage: TJPEGImage;
Bitmap: TBitmap;
tmpPos, tmpLen: integer;
pp: string;
begin
try
if not TextStartsWith(Data, '<[S:') then
begin
// bad data, do something else...
Exit;
end;
tmpPos := Pos('B]>', Data);
pp := Copy(Data, 5, tmpPos-5);
tmpLen := StrToInt(pp);
Data := Copy(Data, tmpPos+3, tmpLen);
Bitmap := TBitmap.Create;
try
JpegImage := TJpegImage.Create;
try
JpegStream := TMemoryStream.Create;
try
TIdDecoderMIME.DecodeStream(Data, JpegStream);
JpegStream.Position := 0;
JpegImage.LoadFromStream(JpegStream);
finally
JpegStream.Free;
end;
with Bitmap do
begin
Canvas.Lock;
try
Width := JpegImage.Width;
Height := JpegImage.Height;
Canvas.Draw(0, 0, JpegImage);
finally
Canvas.Unlock;
end;
end;
finally
JpegImage.Free;
end;
img.Picture.Assign(Bitmap);
finally
Bitmap.Free;
end;
except
on E: Exception do
//
end;
end;
Your problem appears to be that you are treating binary data as though it is text. Binary data can contain anything, for instance #13#10 line breaks or indeed anything whatsoever.
If you wish to send that data as text, then you need to use a text encoding. For example, encode it as base64.
Or transmit the content as binary rather than text.
I try to send a string from a tidtcpserver to a tidtcpclient in Delphi, but when i send a string the client receives nothing. I don't get any errors. I am using tstringstream because i want to send a base64 string(writeln/readln can't send/receive that much text)
This is the send code in idtcpserver1:
procedure TForm1.sendtext(index:integer; txt:string);
var
StrStream:tStream;
List: TList;
AContext: TIdContext;
begin
txt := trim(txt);
strstream := TMemoryStream.Create;
strstream.Write(PAnsiChar(txt)^, Length(txt));
strstream.Position := 0;
List := idTcpServer1.Contexts.LockList;
AContext := TIdContext(List[index]);
AContext.Connection.IOHandler.write(StrStream);
idTcpServer1.Contexts.UnLockList;
end;
This is the read code in idtcpclient1
procedure TIndyClient.Execute;
var
StrStream:tStringStream;
receivedtext:string;
begin
StrStream := tstringstream.Create;
form1.IdTCPClient1.IOHandler.readstream(StrStream);
receivedtext := strstream.DataString;
if receivedtext = '' = false then
begin
showmessage(receivedtext);
end;
end;
Does anyone know what i am doing wrong?
You are making a very common newbie mistake of mismatching the IOHandler.Write(TStream) and IOHandler.ReadStream() calls. By default, ReadStream() expects the stream data to be preceded by the stream size, but Write(TStream) does not send the stream size by default.
Try this instead:
procedure TForm1.sendtext(index: integer; const txt: string);
var
StrStream: TMemoryStream;
List: TList;
AContext: TIdContext;
begin
strStream := TMemoryStream.Create;
try
WriteStringToStream(StrStream, Trim(txt), enUTF8);
List := idTcpServer1.Contexts.LockList;
try
AContext := TIdContext(List[index]);
AContext.Connection.IOHandler.Write(StrStream, 0, True);
finally
idTcpServer1.Contexts.UnlockList;
end;
finally
StrStream.Free;
end;
end;
procedure TIndyClient.Execute;
var
StrStream: TMemoryStream;
receivedtext: string;
begin
StrStream := TMemoryStream.Create;
try
Form1.IdTCPClient1.IOHandler.ReadStream(StrStream, -1, False);
StrStream.Position := 0;
receivedtext := ReadStringFromStream(StrStream, enUTF8);
finally
StrStream.Free;
end;
if receivedtext <> '' then
begin
// ShowMessage() is not thread-safe...
MessageBox(0, PChar(receivedtext), PChar(Application.Title), MB_OK);
end;
end;
Alternatively, because the stream size is now being sent, the receiving code can use ReadString() instead of ReadStream():
procedure TIndyClient.Execute;
var
receivedtext: string;
begin
with Form1.IdTCPClient1.IOHandler do
begin
// you can alternatively set the IOHandler.DefStringEncoding
// instead of passing the encoding as a parameter...
receivedtext := ReadString(ReadLongInt, enUTF8);
end;
if receivedtext <> '' then
begin
// ShowMessage() is not thread-safe...
MessageBox(0, PChar(receivedtext), PChar(Application.Title), MB_OK);
end;
end;
BTW, WriteLn()/ReadLn() do not have any length restrictions, they can handle big strings as long as there is available memory (and the text being sent does not have any line breaks in it). You are probably being confused by ReadLn() being subject to the IOHandler.MaxLineLength, which is set to 16K characters by default, but you can bypass that:
procedure TForm1.sendtext(index: integer; const txt: string);
va
List: TList;
AContext: TIdContext;
begin
List := idTcpServer1.Contexts.LockList;
try
AContext := TIdContext(List[index]);
// you can alternatively set the IOHandler.DefStringEncoding
// instead of passing the encoding as a parameter...
AContext.Connection.IOHandler.WriteLn(Trim(txt), enUTF8);
finally
idTcpServer1.Contexts.UnlockList;
end;
end;
procedure TIndyClient.Execute;
var
receivedtext: string;
begin
// you can alternatively set the IOHandler.DefStringEncoding
// and IOHandler.MaxLineLength instead of passing them as parameters...
receivedtext := Form1.IdTCPClient1.IOHandler.ReadLn(LF, -1, MaxInt, enUTF8);
if receivedtext <> '' then
begin
// ShowMessage() is not thread-safe...
MessageBox(0, PChar(receivedtext), PChar(Application.Title), MB_OK);
end;
end;
I'm creating a new app in XE3 but using some units created in D2007.
I"m getting an error when freeing a TStringList data item. Here's the code that creates the data item FSQL:
procedure TPayorDM.DataModuleCreate(Sender: TObject);
begin
FPayorDRM := TDRM.Create;
FSQL := TStringList.Create;
end;
Here's the code that is getting the error:
procedure TPayorDM.DataModuleDestroy(Sender: TObject);
begin
FreeAndNil(FSQL);
if T_Payor.Active then T_Payor.Close;
FreeAndNil(FPayorDRM);
end;
The error occurs on 'FreeAndNil(FSQL);'. I have tried 'FSQL.Free' and I get the same result.
Here's the error I'm getting:
Project: PayorUpdate.exe raised exception class EInvalidPointer with message 'Invalid pointer operation.
When I break blue arrows (debug mode) is pointing to _FreeMem(Pointer(Self)); in the procedure TObject.FreeInstance in System unit as follows:
procedure TObject.FreeInstance;
begin
CleanupInstance;
_FreeMem(Pointer(Self));
end;
If I don't free the TStringList data item I would have a memory leak in the app.
Is there possibly a configuration option I need to set? I've search with google and have not found anything that explains what I am doing wrong other than one of the three possibilities:
It was allocated by some other memory manager.
It had already been freed once before.
It had never been allocated by anything.
If I put a try ... except... I'm able to get around the issue, but I prefer not to do this.
BTW, I have another TStringList in different unit and I create and FreeAndNil and I do not get any error.
Here is entire source:
unit PayorDataMgr;
interface
uses
SysUtils,
Classes,
Dialogs,
NativeXML,
adscnnct,
DB,
adsdata,
adsfunc,
adstable,
ace,
cbs.drm,
cbs.utils,
cbs.LogFiles;
const
POLICY_TYPES: array[1..3] of string = ('Primary','Secondary','Tertiary');
type
TPayorRecord = Record
ASSIGNBENEFITS: Boolean;
AUTHORIZE: Boolean;
BATCHBILL: Boolean;
CLAIMMAX: Integer;
DISCONTINUED: TDateTime;
DISPENSEUPDATE: Boolean;
EHRSIGNOFF: Boolean;
EMCDEST: String;
FORM: String;
GOVASSIGN: Boolean;
HIDE: Boolean;
IGRPUNIQUE: Integer;
LEGACYPLAN: String;
LEGACYTYPE: String;
LOCALATTN: String;
LOCALCITY: String;
LOCALNAME: String;
LOCALPHONE: String;
LOCALSTATE: String;
LOCALSTREET: String;
LOCALZIP: String;
MASTERATTN: String;
MASTERCITY: String;
MASTERNAME: String;
MASTERPHONE: String;
MASTERSTATE: String;
MASTERSTREET: String;
MASTERZIP: String;
MEDIGAPCODE: String;
MEDIGAPPAYOR: Boolean;
MEDPLANGUID: String;
MODIFIED: TDateTime;
NEICCODE: String;
NEICTYPESTDC: Integer;
OWNER: String;
PAYORGUID: String;
PAYORSUBTYPESTDC: Integer;
PAYORTYPESTDC: Integer;
PAYORUNIQUE: Integer;
PAYPERCENT: Integer;
RTCODE: String;
SRXPLANGUID: String;
STATEFILTER: String;
procedure Clear;
End;
TPayors = Record
private
function _pGetCount: Integer;
public
Items: Array of TPayorRecord;
procedure Add(const aItem:TPayorRecord);
function CarriersList:TStrings;
procedure Free;
function GetPayorGuid(const aPAYORUNIQUE:Integer):String;
function IndexOfIgrpUnique(Const aIGRPUNIQUE:Integer):Integer;
function IndexOfPayorUnique(Const aPAYORUNIQUE:Integer):Integer;
procedure SortByName;
property Count:Integer Read _pGetCount;
End;
TPayorDM = class(TDataModule)
CommonConnection: TAdsConnection;
T_Payor: TAdsTable;
Q_Payor: TAdsQuery;
procedure DataModuleDestroy(Sender: TObject);
procedure DataModuleCreate(Sender: TObject);
private
FPayorDRM: TDRM;
FSQL: TStringList;
function _LoadRecordFromTable:TPayorRecord;
function _newIDSTRING(const aFormat:String='F'):String;
{ Private declarations }
procedure _pSetConnectionHandle(const Value: Integer);
procedure _pSetErrorMessage(const Value: String);
procedure _psetSQL(const Value: TStringList);
{ Private properties }
property ErrorMessage:String Write _pSetErrorMessage;
public
function AddPayor(var aPAYORRECORD:TPAYORRECORD):Boolean;
function ExecuteScript(const aTo,aFrom:string):Boolean;
function FindPayor(const aPAYORGUID:String):Boolean;overload;
function FindPayor(const aPAYORUNIQUE:Integer):Boolean;overload;
function GetPayorData:TDRM;
function GetRecordCount(const aData:String):Integer;
function LoadCarriers(const aHide:boolean = False):TPayors;
function LoadPayor:TPayorRecord;
function OpenTable:Boolean;
function UpdateFromXML(const aPayorNode:TXMLNode):boolean;
{ Public declarations }
property ConnectionHandle:Integer Write _pSetConnectionHandle;
property DynamicPayorFields:TDRM Read FPayorDRM;
property SQL:TStringList Read FSQL Write _psetSQL;
end;
var
PayorDM: TPayorDM;
implementation
{$R *.dfm}
function TPayorDM.AddPayor(var aPAYORRECORD: TPAYORRECORD): Boolean;
begin
Result := False;
if IsNull(aPAYORRECORD.LOCALNAME) then Exit;
{ Create uniques }
{ Add Record }
if not T_Payor.Active then
if not OpenTable then Exit;
with T_Payor do
try
Insert;
FieldByName('PAYORGUID').AsString := _newIDSTRING;
FieldByName('MASTERNAME').AsString := aPAYORRECORD.MASTERNAME;
FieldByName('MASTERSTREET').AsString := aPAYORRECORD.MASTERSTREET;
FieldByName('MASTERCITY').AsString := aPAYORRECORD.MASTERCITY;
FieldByName('MASTERSTATE').AsString := aPAYORRECORD.MASTERSTATE;
FieldByName('PAYORTYPESTDC').AsInteger := aPAYORRECORD.PAYORTYPESTDC;
FieldByName('MASTERZIP').AsString := aPAYORRECORD.MASTERZIP;
FieldByName('MASTERATTN').AsString := aPAYORRECORD.MASTERATTN;
FieldByName('MASTERPHONE').AsString := aPAYORRECORD.MASTERPHONE;
FieldByName('NEICCODE').AsString := aPAYORRECORD.NEICCODE;
FieldByName('RTCODE').AsString := aPAYORRECORD.RTCODE;
FieldByName('STATEFILTER').AsString := aPAYORRECORD.STATEFILTER;
FieldByName('NEICTYPESTDC').AsInteger := aPAYORRECORD.NEICTYPESTDC;
FieldByName('PAYORSUBTYPESTDC').AsInteger := aPAYORRECORD.PAYORSUBTYPESTDC;
FieldByName('OWNER').AsString := aPAYORRECORD.OWNER;
FieldByName('HIDE').AsBoolean := aPAYORRECORD.HIDE;
FieldByName('IGRPUNIQUE').AsInteger := aPAYORRECORD.IGRPUNIQUE;
FieldByName('FORM').AsString := aPAYORRECORD.FORM;
FieldByName('GOVASSIGN').AsBoolean := aPAYORRECORD.GOVASSIGN;
FieldByName('CLAIMMAX').AsInteger := aPAYORRECORD.CLAIMMAX;
FieldByName('MEDIGAPCODE').AsString := aPAYORRECORD.MEDIGAPCODE;
FieldByName('EMCDEST').AsString := aPAYORRECORD.EMCDEST;
FieldByName('ASSIGNBENEFITS').AsBoolean := aPAYORRECORD.ASSIGNBENEFITS;
FieldByName('BATCHBILL').AsBoolean := aPAYORRECORD.BATCHBILL;
FieldByName('MEDIGAPPAYOR').AsBoolean := aPAYORRECORD.MEDIGAPPAYOR;
FieldByName('MEDPLANGUID').AsString := aPAYORRECORD.MEDPLANGUID;
FieldByName('SRXPLANGUID').AsString := aPAYORRECORD.SRXPLANGUID;
FieldByName('PAYPERCENT').AsInteger := aPAYORRECORD.PAYPERCENT;
FieldByName('LOCALNAME').AsString := aPAYORRECORD.LOCALNAME;
FieldByName('LOCALSTREET').AsString := aPAYORRECORD.LOCALSTREET;
FieldByName('LOCALCITY').AsString := aPAYORRECORD.LOCALCITY;
FieldByName('LOCALSTATE').AsString := aPAYORRECORD.LOCALSTATE;
FieldByName('LOCALZIP').AsString := aPAYORRECORD.LOCALZIP;
FieldByName('LOCALATTN').AsString := aPAYORRECORD.LOCALATTN;
FieldByName('LOCALPHONE').AsString := aPAYORRECORD.LOCALPHONE;
FieldByName('EHRSIGNOFF').AsBoolean := aPAYORRECORD.EHRSIGNOFF;
FieldByName('DISCONTINUED').AsDateTime := aPAYORRECORD.DISCONTINUED;
FieldByName('MODIFIED').AsDateTime := Now;
FieldByName('LEGACYPLAN').AsString := aPAYORRECORD.LEGACYPLAN;
FieldByName('LEGACYTYPE').AsString := aPAYORRECORD.LEGACYTYPE;
FieldByName('AUTHORIZE').AsBoolean := aPAYORRECORD.AUTHORIZE;
FieldByName('DISPENSEUPDATE').AsBoolean := aPAYORRECORD.DISPENSEUPDATE;
Post;
aPAYORRECORD.PAYORUNIQUE := FieldByName('PAYORUNIQUE').AsInteger;
aPAYORRECORD.PAYORGUID := FieldByName('PAYORGUID').AsString;
Close;
Result := True;
except on E: EADSDatabaseError do
begin
ErrorMessage := 'AddPayor: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message;
end;
end;
end;
procedure TPayorDM.DataModuleCreate(Sender: TObject);
begin
FPayorDRM := TDRM.Create;
FSQL := TStringList.Create; { FSQL Created }
end;
procedure TPayorDM.DataModuleDestroy(Sender: TObject);
begin
try
FSQL.Free; { FSQL destroyed - work around to get unit to run without error}
except
end;
if T_Payor.Active then T_Payor.Close;
FreeAndNil(FPayorDRM);
end;
function TPayorDM.ExecuteScript(const aTo, aFrom: string):Boolean;
begin
Result := False;
if FSQL.Count = 0 then exit;
with Q_Payor do
try
if Active then Close;
SQL := FSQL;
ParamByName('to').Text := aTo;
ParambyName('from').Text := aFrom;
ExecSQL;
if Active then Close;
Result := True;
except on E: EADSDatabaseError do
begin
ErrorMessage := 'ExecuteScript: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message + ' SQL: ' + Q_Payor.SQL.Text;
end;
end;
end;
function TPayorDM.FindPayor(const aPAYORUNIQUE: Integer): Boolean;
begin
T_Payor.IndexName := 'PAYORUNIQUE';
Result := T_Payor.FindKey([aPAYORUNIQUE]);
end;
function TPayorDM.FindPayor(const aPAYORGUID: String): Boolean;
begin
T_Payor.IndexName := 'PAYORGUID';
Result := T_Payor.FindKey([aPAYORGUID]);
end;
function TPayorDM.GetPayorData: TDRM;
begin
if FPayorDRM.Count = 0 then
FPayorDRM.BuildDRMList(T_Payor);
Result := FPayorDRM;
end;
function TPayorDM.GetRecordCount(const aData:string): Integer;
begin
Result := 0;
if FSQL.Count = 0 then exit;
with Q_Payor do
try
if Active then Close;
SQL := FSQL;
ParamByName('data').AsString := aData;
Open;
Result := RecordCount;
Close;
except on E: EADSDatabaseError do
begin
ErrorMessage := 'GetRecordCount: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message;
end;
end;
end;
function TPayorDM.LoadCarriers(const aHide: boolean): TPayors;
begin
OpenTable;
Result.Free;
with T_Payor do
begin
First;
while not EOF do
begin
if T_Payor.FieldByName('HIDE').AsBoolean = aHide then
Result.Add(_LoadRecordFromTable);
Next;
end;
First;
Result.SortByName;
end;
end;
function TPayorDM.LoadPayor: TPayorRecord;
begin
Result.Clear;
try
if not T_Payor.active then exit;
if T_Payor.RecNo = 0 then exit;
Result := _LoadRecordFromTable;
except on E: EADSDatabaseError do
begin
ErrorMessage := 'LoadPayor: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message;
end;
end;
end;
function TPayorDM.OpenTable: Boolean;
begin
Result := False;
with T_Payor do
try
if not Active then Open;
FPayorDRM.BuildDRMList(T_Payor);
FPayorDRM.LoadValues(T_Payor); { test }
FPayorDRM.ExportDRMList; { test }
Result := True;
except on E: EADSDatabaseError do
begin
ErrorMessage := 'OpenTable: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message;
end;
end;
end;
function TPayorDM.UpdateFromXML(const aPayorNode: TXMLNode): boolean;
var
fKeyData:TXMLNode;
Idx,fPAYORUNIQUE:Integer;
begin
Result := False;
if not Assigned(aPayorNode) then Exit;
try
if FPayorDRM.Count = 0 then
FPayorDRM.BuildDRMList(T_Payor);
FPayorDRM.ClearValues;
fKeyData := aPayorNode.FindNode('KeyData');
FPayorDRM.FindRecordFromKeyData(fKeyData,T_Payor);
fPAYORUNIQUE := FPayorDRM.FieldByName('PAYORUNIQUE').AsInteger;
FPayorDRM.LoadValues(aPayorNode);
if fPAYORUNIQUE = 0 then
begin
FPayorDRM.FieldByName('PAYORUNIQUE').AsInteger := 0;
FPayorDRM.FieldByName('PAYORGUID').AsString := _newIDSTRING;
FPayorDRM.FieldByName('MODIFIED').AsDate := Now;
FPayorDRM.AddRecord(T_Payor)
end
else
begin
FPayorDRM.FieldByName('MODIFIED').AsDate := Now;
FPayorDRM.UpdateRecord(T_Payor);
end;
except on e:exception do
begin
ErrorMessage := 'UpdateFromXML: ERROR: ' + e.Message;
end;
end;
end;
function TPayorDM._LoadRecordFromTable: TPayorRecord;
begin
with T_Payor do
begin
Result.PAYORUNIQUE := FieldByName('PAYORUNIQUE').AsInteger;
Result.PAYORGUID := FieldByName('PAYORGUID').AsString;
Result.MASTERNAME := FieldByName('MASTERNAME').AsString;
Result.MASTERSTREET := FieldByName('MASTERSTREET').AsString;
Result.MASTERCITY := FieldByName('MASTERCITY').AsString;
Result.MASTERSTATE := FieldByName('MASTERSTATE').AsString;
Result.PAYORTYPESTDC := FieldByName('PAYORTYPESTDC').AsInteger;
Result.MASTERZIP := FieldByName('MASTERZIP').AsString;
Result.MASTERATTN := FieldByName('MASTERATTN').AsString;
Result.MASTERPHONE := FieldByName('MASTERPHONE').AsString;
Result.NEICCODE := FieldByName('NEICCODE').AsString;
Result.RTCODE := FieldByName('RTCODE').AsString;
Result.STATEFILTER := FieldByName('STATEFILTER').AsString;
Result.NEICTYPESTDC := FieldByName('NEICTYPESTDC').AsInteger;
Result.PAYORSUBTYPESTDC := FieldByName('PAYORSUBTYPESTDC').AsInteger;
Result.OWNER := FieldByName('OWNER').AsString;
Result.HIDE := FieldByName('HIDE').AsBoolean;
Result.IGRPUNIQUE := FieldByName('IGRPUNIQUE').AsInteger;
Result.FORM := FieldByName('FORM').AsString;
Result.GOVASSIGN := FieldByName('GOVASSIGN').AsBoolean;
Result.CLAIMMAX := FieldByName('CLAIMMAX').AsInteger;
Result.MEDIGAPCODE := FieldByName('MEDIGAPCODE').AsString;
Result.EMCDEST := FieldByName('EMCDEST').AsString;
Result.ASSIGNBENEFITS := FieldByName('ASSIGNBENEFITS').AsBoolean;
Result.BATCHBILL := FieldByName('BATCHBILL').AsBoolean;
Result.MEDIGAPPAYOR := FieldByName('MEDIGAPPAYOR').AsBoolean;
Result.MEDPLANGUID := FieldByName('MEDPLANGUID').AsString;
Result.SRXPLANGUID := FieldByName('SRXPLANGUID').AsString;
Result.PAYPERCENT := FieldByName('PAYPERCENT').AsInteger;
Result.LOCALNAME := FieldByName('LOCALNAME').AsString;
Result.LOCALSTREET := FieldByName('LOCALSTREET').AsString;
Result.LOCALCITY := FieldByName('LOCALCITY').AsString;
Result.LOCALSTATE := FieldByName('LOCALSTATE').AsString;
Result.LOCALZIP := FieldByName('LOCALZIP').AsString;
Result.LOCALATTN := FieldByName('LOCALATTN').AsString;
Result.LOCALPHONE := FieldByName('LOCALPHONE').AsString;
Result.EHRSIGNOFF := FieldByName('EHRSIGNOFF').AsBoolean;
Result.DISCONTINUED := FieldByName('DISCONTINUED').AsDateTime;
Result.MODIFIED := FieldByName('MODIFIED').AsDateTime;
Result.LEGACYPLAN := FieldByName('LEGACYPLAN').AsString;
Result.LEGACYTYPE := FieldByName('LEGACYTYPE').AsString;
Result.AUTHORIZE := FieldByName('AUTHORIZE').AsBoolean;
Result.DISPENSEUPDATE := FieldByName('DISPENSEUPDATE').AsBoolean;
end;
end;
function TPayorDM._newIDSTRING(const aFormat: String): String;
begin
Result := '';
try
with Q_Payor do
try
SQL.Clear;
SQL.Add('SELECT NEWIDSTRING( "' + aFormat + '" ) AS GUID FROM system.iota');
Open;
Result := FieldByName('GUID').AsString;
Close;
except on E: EADSDatabaseError do
begin
ErrorMessage := '_newIDSTRING: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message;
end;
end;
finally
end;
end;
procedure TPayorDM._pSetConnectionHandle(const Value: Integer);
begin
if T_Payor.Active then T_Payor.Close;
CommonConnection.SetHandle(Value);
OpenTable;
end;
procedure TPayorDM._pSetErrorMessage(const Value: String);
begin
WriteError('[TPayorDM]' + Value,LogFilename);
end;
procedure TPayorDM._psetSQL(const Value: TStringList);
begin
FSQL := Value;
end;
{ TPayorRecord }
procedure TPayorRecord.Clear;
begin
PAYORUNIQUE := 0;
PAYORGUID := '';
MASTERNAME := '';
MASTERSTREET := '';
MASTERCITY := '';
MASTERSTATE := '';
PAYORTYPESTDC := 0;
MASTERZIP := '';
MASTERATTN := '';
MASTERPHONE := '';
NEICCODE := '';
RTCODE := '';
STATEFILTER := '';
NEICTYPESTDC := 0;
PAYORSUBTYPESTDC := 0;
OWNER := '';
HIDE := False;
IGRPUNIQUE := 0;
FORM := '';
GOVASSIGN := False;
CLAIMMAX := 0;
MEDIGAPCODE := '';
EMCDEST := '';
ASSIGNBENEFITS := False;
BATCHBILL := False;
MEDIGAPPAYOR := False;
MEDPLANGUID := '';
SRXPLANGUID := '';
PAYPERCENT := 0;
LOCALNAME := '';
LOCALSTREET := '';
LOCALCITY := '';
LOCALSTATE := '';
LOCALZIP := '';
LOCALATTN := '';
LOCALPHONE := '';
EHRSIGNOFF := False;
DISCONTINUED := 0;
MODIFIED := 0;
LEGACYPLAN := '';
LEGACYTYPE := '';
AUTHORIZE := False;
DISPENSEUPDATE := False;
end;
{ TPayors }
procedure TPayors.Add(const aItem: TPayorRecord);
begin
SetLength(Items,Count + 1);
Items[Count - 1] := aItem;
end;
function TPayors.CarriersList: TStrings;
var
I: Integer;
begin
Result := TStringList.Create;
Result.Clear;
SortbyName;
try
for I := 0 to Count - 1 do
Result.Add(Items[I].LOCALNAME);
finally
end;
end;
procedure TPayors.Free;
begin
Items := Nil;
end;
function TPayors.GetPayorGuid(const aPAYORUNIQUE: Integer): String;
var
Idx:Integer;
begin
Result := '';
Idx := IndexOfPayorUnique(aPAYORUNIQUE);
if not (Idx = -1) then
Result := Items[Idx].PAYORGUID;
end;
function TPayors.IndexOfIgrpUnique(const aIGRPUNIQUE: Integer): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to Count - 1 do
if Items[I].IGRPUNIQUE = aIGRPUNIQUE then
begin
Result := I;
Break;
end;
end;
function TPayors.IndexOfPayorUnique(const aPAYORUNIQUE: Integer): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to Count - 1 do
if Items[I].PAYORUNIQUE = aPAYORUNIQUE then
begin
Result := I;
Break;
end;
end;
procedure TPayors.SortByName;
var
fSort:TStringList;
fParse:TStrings;
I,Idx: Integer;
fTempPayor:TPayors;
begin
fSort := TStringList.Create;
fParse := TStringList.Create;
fTempPayor.Items := Self.Items;
fSort.Sorted := True;
try
for I := 0 to Count - 1 do
fSort.Add(Items[I].LOCALNAME + #9 + IntToStr(I));
Items := Nil;
for I := 0 to fSort.Count - 1 do
begin
cbs.utils.ParseDelimited(fParse,fSort[I],#9);
Idx := StrToInt(fParse[1]);
Add(fTempPayor.Items[Idx]);
end;
finally
fTempPayor.Free;
fParse.Free;
fSort.Free;
end;
end;
function TPayors._pGetCount: Integer;
begin
Result := Length(Items);
end;
end.
You are (most probably) double freeing a stringlist (and never freeing at least one). The problem is in the setter of your 'SQL' property (which is backed by the 'FSQL' field):
procedure TPayorDM._psetSQL(const Value: TStringList);
begin
FSQL := Value;
end;
Here you are loosing the reference to the already existing stringlist (LHS). Consider the below scenario:
You call
PayorDM.SQL := AStringList;
and the reference to the private field you created in the constructor is gone, instead you keep a reference to 'AStringList'. After that at some point you destroy 'AStringList', now the 'FSQL' field is a stale pointer. When in the destructor you call
FSQL.Free;
you get an invalid pointer operation.
Change your setter to:
procedure TPayorDM._psetSQL(const Value: TStringList);
begin
FSQL.Assign(Value);
end;
I'm building a Delphi XE3 application which needs to be able to have files dropped onto it. I have the Explorer > Application side of things working, but for the life of me can't figure out to get the filename when going from Application > Application.
Assuming one file is dropped from say Outlook (or any other application), I have this which works as long as I manually assign filename before hand.
SetFormatEtc( FormatEtc , CF_FILECONTENTS );
OleCheck( dataObj.GetData( FormatEtc , Medium ) );
OleStream := TOleStream.Create( IUnknown( Medium.stm ) as IStream );
MemStream := TMemoryStream.Create;
OleStream.Position := 0;
MemStream.CopyFrom( OleStream , OleStream.Size );
TMemoryStream( MemStream ).SaveToFile( 'C:\' + filename );
MemStream.Free;
OleStream.Free;
ReleaseStgMedium( Medium );
CF_FILECONTENTS format can contain several stream. You must check CF_FILEDESCRIPTORW and CF_FILEDESCRIPTORA formats for detection of stream count and stream names. Some sources:
function ContainFormat(ADataObject: IDataObject; AFormat: TClipFormat;
ATymed: Longint; AAspect: LongInt = DVASPECT_CONTENT; AIndex: LongInt = -1): Boolean;
var Format: TFormatEtc;
begin
ZeroMemory(#Format, SizeOf(Format));
Format.cfFormat := AFormat;
Format.dwAspect := AAspect;
Format.lindex := AIndex;
Format.tymed := ATymed;
Result := ADataObject.QueryGetData(Format) = S_OK;
end;
procedure InvalidMedium;
begin
raise Exception.Create('Invalid medium');
end;
function ExtractStream(ADataObject: IDataObject; AIndex: Integer): IStream;
var Format: TFormatEtc;
Medium: TStgMedium;
begin
ZeroMemory(#Format, SizeOf(Format));
Format.cfFormat := CF_FILECONTENTS;
Format.dwAspect := DVASPECT_CONTENT;
Format.lindex := AIndex;
Format.tymed := TYMED_ISTREAM;
ZeroMemory(#Medium, SizeOf(Medium));
OleCheck(ADataObject.GetData(Format, Medium));
try
if (Medium.tymed and TYMED_ISTREAM = 0) or not Assigned(Medium.stm) then
InvalidMedium;
Result := IStream(Medium.stm);
finally
ReleaseStgMedium(Medium);
end
end;
procedure WorkWithDropObject(const AFileName: UnicodeString; AStream: IStream);
begin
end;
procedure ProcessDataObject(ADataObject: IDataObject);
var Format: TFormatEtc;
Medium: TStgMedium;
FGDA: PFileGroupDescriptorA;
FGDW: PFileGroupDescriptorW;
i: Integer;
Stream: IStream;
begin
if ContainFormat(ADataObject, CF_FILECONTENTS, TYMED_ISTREAM) then
begin
if ContainFormat(ADataObject, CF_FILEDESCRIPTORW, TYMED_HGLOBAL) then
begin
Format.cfFormat := CF_FILEDESCRIPTORW;
Format.dwAspect := DVASPECT_CONTENT;
Format.lindex := -1;
Format.tymed := TYMED_HGLOBAL;
ZeroMemory(#Medium, SizeOf(Medium));
OleCheck(ADataObject.GetData(Format, Medium));
try
if (Medium.tymed and TYMED_HGLOBAL = 0) or (Medium.hGlobal = 0) then
InvalidMedium;
FGDW := GlobalLock(Medium.hGlobal);
if not Assigned(FGDW) then
RaiseLastOSError;
try
for i := 0 to FGDW.cItems - 1 do
begin
Stream := ExtractStream(ADataObject, i);
try
WorkWithDropObject(FGDW.fgd[i].cFileName, Stream);
finally
Stream := nil;
end;
end;
finally
GlobalUnlock(Medium.hGlobal);
end;
finally
ReleaseStgMedium(Medium);
end
end
else
if ContainFormat(ADataObject, CF_FILEDESCRIPTORA, TYMED_HGLOBAL) then
begin
Format.cfFormat := CF_FILEDESCRIPTORA;
Format.dwAspect := DVASPECT_CONTENT;
Format.lindex := -1;
Format.tymed := TYMED_HGLOBAL;
ZeroMemory(#Medium, SizeOf(Medium));
OleCheck(ADataObject.GetData(Format, Medium));
try
if (Medium.tymed and TYMED_HGLOBAL = 0) or (Medium.hGlobal = 0) then
InvalidMedium;
FGDA := GlobalLock(Medium.hGlobal);
if not Assigned(FGDA) then
RaiseLastOSError;
try
for i := 0 to FGDA.cItems - 1 do
begin
Stream := ExtractStream(ADataObject, i);
try
WorkWithDropObject(FGDA.fgd[i].cFileName, Stream);
finally
Stream := nil;
end;
end;
finally
GlobalUnlock(Medium.hGlobal);
end;
finally
ReleaseStgMedium(Medium);
end
end;
end;
end;
Also I you want to create universal software you should process the following formats:
CF_FILENAMEW/CF_FILENAMEA
CF_HDROP
CF_IDLIST
CF_FILEDESCRIPTORW/CF_FILEDESCRIPTORA/CF_FILECONTENTS
I am trying to post data to bing with this code
function PostExample: string;
var
lHTTP: TIdHTTP;
lParamList: TStringList;
begin
lParamList := TStringList.Create;
lParamList.Add('q=test');
lHTTP := TIdHTTP.Create(nil);
try
Result := lHTTP.Post('http://www.bing.com/', lParamList);
finally
FreeAndNil(lHTTP);
FreeAndNil(lParamList);
end;
end;
And then, how can I get the result to the TWebBrowser and display it?
Try LoadDocFromString:
procedure LoadBlankDoc(ABrowser: TWebBrowser);
begin
ABrowser.Navigate('about:blank');
while ABrowser.ReadyState <> READYSTATE_COMPLETE do
begin
Application.ProcessMessages;
Sleep(0);
end;
end;
procedure CheckDocReady(ABrowser: TWebBrowser);
begin
if not Assigned(ABrowser.Document) then
LoadBlankDoc(ABrowser);
end;
procedure LoadDocFromString(ABrowser: TWebBrowser; const HTMLString: wideString);
var
v: OleVariant;
HTMLDocument: IHTMLDocument2;
begin
CheckDocReady(ABrowser);
HTMLDocument := ABrowser.Document as IHTMLDocument2;
v := VarArrayCreate([0, 0], varVariant);
v[0] := HTMLString;
HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
HTMLDocument.Close;
end;
Or you can use the memory streams for loading
uses
OleCtrls, SHDocVw, IdHTTP, ActiveX;
function PostRequest(const AURL: string; const AParams: TStringList;
const AWebBrowser: TWebBrowser): Boolean;
var
IdHTTP: TIdHTTP;
Response: TMemoryStream;
begin
Result := True;
try
AWebBrowser.Navigate('about:blank');
while AWebBrowser.ReadyState < READYSTATE_COMPLETE do
Application.ProcessMessages;
Response := TMemoryStream.Create;
try
IdHTTP := TIdHTTP.Create(nil);
try
IdHTTP.Post(AURL, AParams, Response);
if Response.Size > 0 then
begin
Response.Position := 0;
(AWebBrowser.Document as IPersistStreamInit).Load(
TStreamAdapter.Create(Response, soReference));
end;
finally
IdHTTP.Free;
end;
finally
Response.Free;
end;
except
Result := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Params: TStringList;
begin
Params := TStringList.Create;
try
Params.Add('q=test');
if not PostRequest('http://www.bing.com/', Params, WebBrowser1) then
ShowMessage('An unexpected error occured!');
finally
Params.Free;
end;
end;