I tried this code to save some fields and an image.
I use MySQL and zzeos for connectinf to the database.
How to fix this code ?
procedure Tfbiodata.btnSaveClick(Sender: TObject);
var
gambar : TMemoryStream;
begin
if (edtnis.Text='') or (edtname.Text='') or (cmbjk.Text='') or (edtempat.Text='') or (edtgl.Text='') or (cmbtingkatan.Text='') then
begin
ShowMessage('Maaf !!! Data Anda Belum Lengkap ....');
exit;
end;
begin
zbiodata2.Open;
zbiodata2.Append;
zbiodata2.FieldByName('NIS').AsString := edtnis.Text;
zbiodata2.FieldByName('Nama_siswa').AsString := edtname.Text;
zbiodata2.FieldByName('Jenis_kelamin').AsString := cmbjk.Text;
zbiodata2.FieldByName('Tempat_lahir').AsString := edtempat.Text;
zbiodata2.FieldByName('Tanggal_lahir').AsString := edtgl.Text;
zbiodata2.FieldByName('Tingkatan').AsString := cmbtingkatan.Text;
zbiodata2.FieldByName('Hasil_indentifkasi').AsString := lblhasil.Caption;
zbiodata2.FieldByName('Metode_pembeaaran').AsString := memo1.Text;
try
convertobmp(openpicture.FileName);
gambar := TMemorystream.Create;
image1.Picture.Graphic.SaveToStream(gambar);
zbiodata2.SQL.Text := 'insert into biodata (gambar) values (:p0)';
zbiodata2.Params[0].LoadFromStream(gambar,ftBlob);
zbiodata2.Post;
zbiodata2.ExecSQL;
except
on E:Exception do
ShowMessage('sorry this a problem .' + #13 + 'Error : ' + E.Message);
end;
end;
end;
When I run this code, I get the error "sorry this is a problem . Error: List index out of bounds(2)"
After calling image1.Picture.Graphic.SaveToStream(gambar), set gambar.Position back to 0 before then calling zbiodata2.Params[0].LoadFromStream(gambar,ftBlob):
image1.Picture.Graphic.SaveToStream(gambar);
gambar.Position := 0; // <-- add this
zbiodata2.Params[0].LoadFromStream(gambar,ftBlob);
With that said, you are using zbiodata2 for two different operations at the same time - editing a new row that is being appended, and executing an SQL statement. Don't do that! Use separate components for each operation.
If the image is being saved into the same row that is being appended, don't bother executing a separate SQL INSERT statement at all. Save the image data directly into the row's gambar TField before then calling zbiodata2.Post():
procedure Tfbiodata.btnSaveClick(Sender: TObject);
var
gambar : TStream;
begin
if (edtnis.Text='') or (edtname.Text='') or (cmbjk.Text='') or (edtempat.Text='') or (edtgl.Text='') or (cmbtingkatan.Text='') then
begin
ShowMessage('Maaf !!! Data Anda Belum Lengkap ....');
Exit;
end;
try
convertobmp(openpicture.FileName);
zbiodata2.Open;
zbiodata2.Append;
try
zbiodata2.FieldByName('NIS').AsString := edtnis.Text;
zbiodata2.FieldByName('Nama_siswa').AsString := edtname.Text;
zbiodata2.FieldByName('Jenis_kelamin').AsString := cmbjk.Text;
zbiodata2.FieldByName('Tempat_lahir').AsString := edtempat.Text;
zbiodata2.FieldByName('Tanggal_lahir').AsString := edtgl.Text;
zbiodata2.FieldByName('Tingkatan').AsString := cmbtingkatan.Text;
zbiodata2.FieldByName('Hasil_indentifkasi').AsString := lblhasil.Caption;
zbiodata2.FieldByName('Metode_pembeaaran').AsString := memo1.Text;
if (image1.Picture.Graphic <> nil) and (not image1.Picture.Graphic.Empty) then
begin
gambar := TMemoryStream.Create;
try
image1.Picture.Graphic.SaveToStream(gambar);
gambar.Position := 0;
(zbiodata2.FieldByName('gambar') as TBlobField).LoadFromStream(gambar);
finally
gambar.Free;
end;
{
Alternatively:
gambar := zbiodata2.CreateBlobStream(zbiodata2.FieldByName('gambar'), bmWrite);
try
image1.Picture.Graphic.SaveToStream(gambar);
finally
gambar.Free;
end;
}
end;
zbiodata2.Post;
except
zbiodata2.Cancel;
raise;
end;
except
on E:Exception do
ShowMessage('sorry this a problem .' + #13 + 'Error : ' + E.Message);
end;
end;
If you are still having problems after that, you need to explain what is actually going wrong, what errors you are seeing, etc.
Related
All,
I am working on a new datasnap project based on the example project located in C:\Users\Public\Documents\Embarcadero\Studio\18.0\Samples\Object Pascal\DataSnap\FireDAC_DBX.
I am trying to transfer a large stream (1,606,408 bytes) from datasnap server to client. I am running into what appears to be a common issue and that is that the entire stream does not make it to the client.
Here is my server code:
//Returns Customer Info
function TServerMethods.GetBPInfo(CardCode : String): TStringStream;
begin
Result := TStringStream.Create;
try
qBPInfo.Close;
if CardCode.Trim = '' then
qBPInfo.ParamByName('ParmCardCode').AsString := '%%'
else
qBPInfo.ParamByName('ParmCardCode').AsString := '%' + CardCode + '%';
qBPInfo.Open;
FDSchemaAdapterBPInfo.SaveToStream(Result, TFDStorageFormat.sfBinary);
Result.Position := 0;
// Result.SaveToFile('output.adb');
except
raise;
end;
end;
Here is my client code:
procedure TdmDataSnap.GetBPInfo(CardCode : String);
var
LStringStream : TStringStream;
begin
dmDataSnap.FDStoredProcBPInfo.ParamByName('CardCode').AsString := CardCode;
FDStoredProcBPInfo.ExecProc;
LStringStream := TStringStream.Create(FDStoredProcBPInfo.ParamByName('ReturnValue').asBlob);
//LStringStream.Clear;
//LStringStream.LoadFromFile('Output.adb');
try
if LStringStream <> nil then
begin
LStringStream.Position := 0;
try
DataModuleFDClient.FDSchemaAdapterBP.LoadFromStream(LStringStream, TFDStorageFormat.sfBinary);
except
on E : Exception do
showmessage(e.Message);
end;
end;
finally
LStringStream.Free;
end;
end;
You will see the stream save and load code; that is how I determined that the server was getting the entire result set into the stream, and that the client could handle the entire result set and display it properly.
So smaller streams transfer just fine, but this big one, when examined in the ide debugger, does not start with the 65,66,68,83 characters and the load fails with the error, '[FireDAC][Stan]-710. Invalid binary storage format'.
I know from extended Googling that there are work-arounds for this, but I do not understand how to apply the workarounds to my case, with the use of Tfdstoredproc and TfdSchemaAdaptor components. I'm trying to stay with this coding scheme.
How do I adapt this code to correctly receive large streams?
Update 1:
Ok, I tried strings and Base64 encoding. It didn't work.
Client Code:
procedure TdmDataSnap.GetBPInfo(CardCode : String);
var
LStringStream : TStringStream;
TempStream : TStringStream;
begin
dmDataSnap.FDStoredProcBPInfo.ParamByName('CardCode').AsString := CardCode;
FDStoredProcBPInfo.ExecProc;
try
TempStream := TStringStream.Create;
TIdDecoderMIME.DecodeStream(FDStoredProcBPInfo.ParamByName('ReturnValue').asString,TempStream);
if TempStream <> nil then
begin
TempStream.Position := 0;
try
DataModuleFDClient.FDSchemaAdapterBP.LoadFromStream(TempStream, TFDStorageFormat.sfBinary);
except
on E : Exception do
showmessage(e.Message);
end;
end;
finally
TempStream.Free;
end;
end;
Here is my server code:
//Returns Customer Info
function TServerMethods.GetBPInfo(CardCode : String): String;
var
TempStream : TMemoryStream;
OutputStr : String;
begin
Result := '';
TempStream := TMemoryStream.Create;
try
try
qBPInfo.Close;
if CardCode.Trim = '' then
qBPInfo.ParamByName('ParmCardCode').AsString := '%%'
else
qBPInfo.ParamByName('ParmCardCode').AsString := '%' + CardCode + '%';
qBPInfo.Open;
FDSchemaAdapterBPInfo.SaveToStream(TempStream, TFDStorageFormat.sfBinary);
TempStream.Position := 0;
OutputStr := IdEncoderMIMEBPInfo.EncodeStream(TempStream);
Result := OutputStr
except
raise;
end;
finally
TempStream.Free;
end;
end;
The result is the same.
I have the following code I use for retrieving mails from a POP3 account.
It is working very well most of the time, but from time to time there are some mails where it doesn't retrieve the body.
If I test the IdMessage.MessageParts.Count it says that it is 0 - if I use another mailclient to retrieve the mail there is no problem.
I have a TIdPOP3 and a TIdMessage component on the form.
The connection is OK as there may be some mails that are show OK.
I can't figure out any system in which mails are not shown correct and which are not. But there might be one.
I use Delphi XE3 and the Indy is version 10.5.9.0
procedure TfrmJsMailCollect.lstMailsClick(Sender: TObject);
var
MailBody: string;
intIndex: integer;
begin
if (lstMails.Items.Count = 0) or (lstMails.SelCount = 0) then
Exit;
MailBody := '';
try
begin
mmoBody.Clear;
lstMails.Selected.SubItems.Strings[0];
lstMails.Selected.ImageIndex := 4;
conPOP3.Retrieve(lstMails.Selected.Index + 1, IdMessage);
for intIndex := 0 To Pred(IdMessage.MessageParts.Count) do
begin
if (IdMessage.MessageParts.Items[intIndex] is TIdAttachmentFile) then
begin // Attachments are skipped
end
else
begin // body text
if Pos('text/plain', IdMessage.MessageParts.Items[intIndex].ContentType) <> 0 then
begin
if TIdText(IdMessage.MessageParts.Items[intIndex]).Body.Text <> '' then
begin
MailBody := MailBody + TIdText(IdMessage.MessageParts.Items[intIndex]).Body.Text;
mmoBody.Lines.Add(MailBody);
MemoValidate;
end;
end;
end;
end;
end;
mmoBody.CaretPos.SetLocation(0, 0);
Application.ProcessMessages;
except
Logfile.Error('F_JsMailCollect.lstMailsClick - ' + cxGetResourceString(#sLangPop3ErrorReading));
end;
end;
With advice from Remy Lebeau and searching the web I ended up with the code below. This does the trick for now, but I would like to improve it so that the memo on my form only shows a nice message that would be readable for everyone - but that may come later.
procedure TfrmJsMailCollect.lstMailsClick(Sender: TObject);
var
MailBody: string;
i: integer;
ContentType: string;
begin
if (lstMails.Items.Count = 0) or (lstMails.SelCount = 0) then
Exit;
try
MailBody := '';
mmoBody.Clear;
lstMails.Selected.SubItems.Strings[0];
lstMails.Selected.ImageIndex := 4;
conPOP3.Retrieve(lstMails.Selected.Index + 1, IdMessage);
ContentType := IdMessage.ContentType;
case PosInStrArray(ContentType, ['multipart/mixed', 'multipart/alternative', 'text/html', 'text/plain'], False) of
0: begin { multipart/mixed }
for i := 0 To Pred(IdMessage.MessageParts.Count) do
begin
if TIdText(IdMessage.MessageParts.Items[i]).Body.Text <> '' then
begin
MailBody := MailBody + TIdText(IdMessage.MessageParts.Items[i]).Body.Text;
mmoBody.Lines.Add(MailBody);
MemoValidate;
end;
end;
end;
1: begin { multipart/alternative }
for i := 0 To Pred(IdMessage.MessageParts.Count) do
begin
if TIdText(IdMessage.MessageParts.Items[i]).Body.Text <> '' then
begin
MailBody := MailBody + TIdText(IdMessage.MessageParts.Items[i]).Body.Text;
mmoBody.Lines.Add(MailBody);
MemoValidate;
end;
end;
end;
2: begin { text/html }
mmoBody.Lines := IdMessage.Body;
MemoValidate;
end;
3: begin { text/plain }
mmoBody.Lines := IdMessage.Body;
MemoValidate;
end;
else
// nothing supported to display...
end;
mmoBody.CaretPos.SetLocation(0, 0);
Application.ProcessMessages;
except
Logfile.Error('F_JsMailCollect.lstMailsClick - ' + cxGetResourceString(#sLangPop3ErrorReading));
end;
end;
Not all email content is parsed into the TIdMessage.MessageParts collection. MIME parts and attachments are, but other content gets parsed into the TIdMessage.Body instead, which you are completely ignoring. You need to look at the TIdMessage.ContentType when deciding where to extract content from. Attachments will always be in TIdMessage.MessageParts, but text may or may not be, depending on the TIdMessage.ContentType.
This program raises an I/O 104 error on EoF when first entering the while loop.
The purpose of the program is to look up if a username is already taken. The existing usernames are stored in a text file.
procedure TForm1.btnRegisterClick(Sender: TObject);
begin
sCUser := edtUserName.Text;
AssignFile(tNames, 'Names.txt');
begin
try
Reset(tNames);
except
ShowMessage('File not found');
Exit;
end;
end;
rewrite(tNames);
while not EoF(tNames) do // I get a I/O 104 Error here `
begin
Readln(tNames, sLine);
iPosComme := Pos(',', sLine);
sUser := Copy(sLine, 1, iPosComme - 1);
Delete(sLine, 1, iPosComme - 1);
if sCUser = sUser then begin
ShowMessage('Username taken');
end
else
begin
rewrite(tNames);
Writeln(tNames, sCUser + ',' + '0');
CloseFile(tNames);
end;
end;
end;
Remove the call to Rewrite()before Eof(). Even if you were not getting an IO error, your code would still fail because Rewrite() closes the file you opened with Reset() and then it creates a new bank file, so Eof() would always be True.
Update: error 104 is file not open for input, which means Reset() is not opening the file but is not raising an exception (which sounds like an RTL bug if Eof() is raising an exception, indicating that {I+} is active).
In any case, using AssignFile() and related routines is the old way to do file I/O. You should use newer techniques, like FileOpen() with FileRead(), TFileStream with TStreamReader, TStringList, etc...
Update: your loop logic is wrong. You are comparing only the first line. If it does not match the user, you are wiping out the file, writing the user to a new file, closing the file, and then continuing the loop. EoF() will then fail at that point. You need to rewrite your loop to the following:
procedure TForm1.btnRegisterClick(Sender: TObject
var
SCUser, sUser: String;
tNames: TextFile;
iPosComme: Integer;
Found: Boolean;
begin
sCUser := edtUserName.Text;
AssignFile(tNames,'Names.txt');
try
Reset(tNames);
except
ShowMessage('File not found');
Exit;
end;
try
Found := False;
while not EoF(tNames) do
begin
Readln(tNames,sLine);
iPosComme := Pos(',', sLine);
sUser := Copy(sLine ,1,iPosComme -1);
if sCUser = sUser then
begin
ShowMessage('Username taken') ;
Found := True;
Break;
end;
end;
if not Found then
Writeln(tNames,sCUser + ',0');
finally
CloseFile(tNames);
end;
end;
For the sake of completeness, this Version works for me, but it is hard to guess what the code is intended to do. Especially the while loop seems a bit displaced, since the file will contain exactly one line after the rewrite-case has ben hit once.
program wtf;
{$APPTYPE CONSOLE}
{$I+}
uses
SysUtils;
procedure Sample( sCUser : string);
var sUser, sLine : string;
iPosComme : Integer;
tnames : textfile;
begin
AssignFile(tNames,'Names.txt');
try
Reset(tNames);
except
Writeln('File not found');
Exit;
end;
while not EoF(tNames) do
begin
Readln(tNames,sLine);
iPosComme := Pos(',', sLine);
sUser := Copy(sLine ,1,iPosComme -1);
Delete( sLine,1, iPosComme -1);
if sCuser = sUser then begin
Writeln('Username taken') ;
end
else begin
Rewrite(tNames);
Writeln(tNames,sCUser + ',' + '0');
CloseFile(tNames);
Break; // file has been overwritten and closed
end;
end;
end;
begin
try
Sample('foobar');
except
on E: Exception do Writeln(E.ClassName, ': ', E.Message);
end;
end.
I wrote a version of this method that uses the newer TStreamReader and TStreamWriter classes.
This won't work with Delphi 7 of course, it's just to show how this could be done in newer versions of Delphi.
The code was heavily inspired by Remys answer.
procedure TForm1.btnRegisterClick(Sender: TObject);
var
Stream: TStream;
Reader: TStreamReader;
Writer: TStreamWriter;
Columns: TStringList;
UserName: string;
Found: Boolean;
FileName: string;
Encoding: TEncoding;
begin
FileName := ExpandFileName('Names.txt'); // An absolute path would be even better
UserName := edtUsername.Text;
Found := False;
Encoding := TEncoding.Default; // or another encoding, e.g. TEncoding.Unicode for Unicode
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Reader := TStreamReader.Create(Stream, Encoding);
try
Columns := TStringList.Create;
try
Columns.Delimiter := ',';
Columns.StrictDelimiter := True; // or False, depending on the file format
while not Reader.EndOfStream do
begin
Columns.DelimitedText := Reader.ReadLine;
if Columns.Count > 0 then
begin
if AnsiSameStr(Columns[0], UserName) then // or AnsiSameText if UserName is not case-sensitive
begin
ShowMessage('Username taken') ;
Found := True;
Break;
end;
end;
end;
finally
Columns.Free;
end;
finally
Reader.Free;
end;
finally
Stream.Free;
end;
if not Found then
begin
Writer := TStreamWriter.Create(FileName, True, Encoding);
try
// Warning: This will cause problems when the file does not end with a new line
Writer.WriteLine(UserName + ',0');
finally
Writer.Free;
end;
end;
end;
If performance and memory usage are not a concern:
procedure TForm1.btnRegisterClick(Sender: TObject);
var
Rows: TStringList;
Columns: TStringList;
UserName: string;
Found: Boolean;
FileName: string;
Encoding: TEncoding;
Row: string;
begin
FileName := ExpandFileName('Names.txt'); // An absolute path would be even better
UserName := edtUsername.Text;
Found := False;
Encoding := TEncoding.Default; // or another encoding, e.g. TEncoding.Unicode for Unicode
Rows := TStringList.Create;
try
Rows.LoadFromFile(FileName, Encoding);
Columns := TStringList.Create;
try
Columns.Delimiter := ',';
Columns.StrictDelimiter := True; // or False, depending on the file format
for Row in Rows do
begin
Columns.DelimitedText := Row;
if Columns.Count > 0 then
begin
if AnsiSameStr(Columns[0], UserName) then // or AnsiSameText if UserName is not case-sensitive
begin
ShowMessage('Username taken') ;
Found := True;
Break;
end;
end;
end;
finally
Columns.Free;
end;
if not Found then
begin
Rows.Add(UserName + ',0');
Rows.SaveToFile(FileName, Encoding);
end;
finally
Rows.Free;
end;
end;
This solution can be adapted to Delphi 7 by removing the Encoding variable.
If it's part of a bigger database it should be stored in a real database management system rather than a text file.
hello i have this code running today but problem is that when there are same data on fields it doesnt cycle but just shows the first data that it filters.
here is the code
ADOTable1.First;
if ADOTable1.Locate('Last', Edit1.Text, []) then
begin
Label1.Caption := ADOTable1.FieldByName('Last').AsString;
Label2.Caption := ADOTable1.FieldByName('First').AsString;
Label3.Caption := ADOTable1.FieldByName('address').AsString;
Next;
end
else
begin
Label1.Caption := '';
Label2.Caption := '';
Label3.Caption := '';
end;
Locate locates the first record that matches the specified criteria in the DataSet.
If a record was found, that record becomes the active/current record.
It cannot be used to locate a "Next" match.
You might want to use a Filter criteria with FindFirst/FindNext e.g.:
DataSet.Filter := 'Last = ''' + Edit1.Text + '''';
if DataSet.FindFirst then
begin
ShowMessage('Found First!');
while DataSet.FindNext do
begin
ShowMessage('Found Next!');
end;
end;
If you want to Filter all records that matches your criteria simply use:
DataSet.Filter := 'Last = ''' + Edit1.Text + '''';
DataSet.Filtered := True; // apply filter for the dataset
Now only those records that meet the filter's conditions are available in the DataSet.
Then iterate the DataSet:
DataSet.First;
while not DataSet.Eof do
begin
// do something with the record
DataSet.Next;
end;
thanks. got this code so far last night
procedure TMain.Button1Click(Sender: TObject);
begin
ADOTable1.First;
while not ADOTable1.EOF do
begin
if (ADOTable1.FieldByName('Last Name').AsString = edit1.Text)
then begin
Label1.Caption := ADOTable1.FieldByName('Last Name').AsString;
Label2.Caption := ADOTable1.FieldByName('First Name').AsString;
Label3.Caption := ADOTable1.FieldByName('MI').AsString;
end;
ShowMessage('click ok for next profile');
ADOTable1.Next;
end;
it maybe same as the code you have given but this code searches for each line on the db grid and thus each line makes me press the ok button once.is it possible to click ok once then the code will search for the next matching data rather than it searching each row?
Using Delphi 2010, UniDAC components, Firebird 2.5 SuperServer.
Database character set is ISO_8559_1 (my Windows default).
I am writing a data transfer application to transfer data from an Access database to a Firebird database that has identical table structure. I am using a ADOQuery component to select all rows from source table, and then looping through that recordset, and using UniSQL component with an INSERT statement with parameters, assigning parameter values from the corresponding source dataset field values.
When running the insert command, it throws a 'Malformed string' exception.
I am stuck and need help to resolve the issue.
Code follows:
function TDataTransfer.BeginTransfer(AProgressCallback: TProgressCallback): Boolean;
var
slSQLSelect, slSQLInsert: TStringList;
i, f, z: Integer;
cmdS, cmdI: String;
adods: TADODataSet;
fbcmd: TUniSQL;
fbscript: TUniscript;
q: String;
s : WideString;
begin
FProgressCallback := AProgressCallback;
fbscript := TUniscript.Create(nil);
try
fbscript.Connection := FirebirdConnection;
FirebirdConnection.StartTransaction;
try
fbscript.Delimiter := ';';
fbscript.ExecuteFile(ExtractFilePath(ParamStr(0)) + 'Firebird_Script_0.txt');
FirebirdConnection.CommitRetaining;
slSQLSelect := TStringList.Create;
slSQLInsert := TStringList.Create;
adods := TADODataSet.Create(nil);
fbcmd := TUniSQL.Create(nil);
try
adods.Connection := AccessConnection;
fbcmd.Connection := FirebirdConnection;
slSQLSelect.LoadFromFile(ExtractFilePath(ParamStr(0)) + 'Access_Select.txt');
slSQLInsert.LoadFromFile(ExtractFilePath(ParamStr(0)) + 'Firebird_Insert.txt');
z := slSQLSelect.Count - 1;
for i := 0 to z do begin
cmdS := slSQLSelect[i];
cmdI := slSQLInsert[i];
adods.CommandText := cmdS;
fbcmd.SQL.Text := cmdI;
adods.Open;
while not adods.Eof do begin
for f := 0 to adods.FieldCount - 1 do
try
if adods.FieldDefs[f].DataType = ftWideString then begin
s := adods.Fields[f].AsAnsiString ;
q := '"';
// if AnsiStrPos(PAnsiChar(#s), PAnsiChar(q)) <> nil then
// s := StringReplace(s, '"', '""', [rfReplaceAll]);
fbcmd.Params[f].Value := s;
end
else
if adods.FieldDefs[f].DataType = ftWideMemo then
fbcmd.Params[f].SetBlobData(adods.CreateBlobStream(adods.Fields[f], bmRead))
else
fbcmd.Params[f].Value := adods.Fields[f].Value;
except
raise;
end;
try
fbcmd.Execute;
// FirebirdConnection.CommitRetaining;
except
raise;
end;
adods.Next;
end;
adods.Close;
FProgressCallback((i + 1) * 100 div (z + 1), 10);
end;
finally
slSQLSelect.Free;
slSQLInsert.Free;
adods.Free;
fbcmd.Free;
end;
fbscript.ExecuteFile(ExtractFilePath(ParamStr(0)) + 'Firebird_Script_1.txt');
FirebirdConnection.Commit;
Result := True;
except
FirebirdConnection.Rollback;
Result := False;
end;
finally
fbscript.Free;
end;
end;
TIA,
SteveL
If you try to replace s := StringReplace(s, '"', '""', [rfReplaceAll]); with s := StringReplace(s, '''''', '''', [rfReplaceAll]); and uncomment the line;