|
Can any body tell me how to get a server ip address in a textbox.
I have sqlserver 2000 in my lan and i am using vb.net 2003.
Please help me
|
|
|
|
|
Hi programmers,
i get the cannot connect to smtp server error when i try to send mail through mail from my vb application.
i used aspsmartmail componet for this.
the mails goes correctly when i use normal outlook express or my domain account through internet explorer but gives error when i send it through my code.
i am giving the code snippet which sends mails. sorry i cant give full details of my mail server and email account in code snippet plz consider for this.
plz help me guys.
Dim mySmartMail As aspSmartMail.SmartMail<br />
Set mySmartMail = New aspSmartMail.SmartMail<br />
<br />
mySmartMail.Server = "ip address of mail server"<br />
mySmartMail.ServerTimeOut = 35<br />
mySmartMail.UserName = "username"<br />
mySmartMail.Password = "password"<br />
<br />
mySmartMail.SenderAddress = "test@mydomain.com" <br />
<br />
<br />
mySmartMail.Recipients.Add "nitin@mydomain.com"<br />
<br />
mySmartMail.Subject = "my mail"<br />
mySmartMail.Body = "body"<br />
<br />
mySmartMail.SendMail<br />
<br />
Set mySmartMail = Nothing<br />
<br />
Help!
Nitin...
|
|
|
|
|
Well, you'll most likely have to get with the people that wrote that component. If you purchased it, then you have at least 1 FREE support incident, otherwise it's $159/incident.
If the IP works in Outlook, the exact same server name/IP should work in this component. If it's not, there might be some setting in this component that you have to set, but have so far failed to do so. I have no idea what that would be, since I've never used this component.
Another possibility is that you have the free version and it expires. If so, then you'll have to shovel out the money to get the full version.
Dave Kreskowiak
Microsoft MVP - Visual Basic
|
|
|
|
|
With VS2003 in a webapplication.
I want to have a messagebox to pop up when a user fills data into a textbox and this data is invalid. spesifically : there is a field for filling in a price, I have a function that makes sure that the data is valid and in range. But I want to inform the user that the data is invalid. If tried using the msgbox(...) function but I take it that it cant be used in a webpage, in that way.
Is there a way to do this?
|
|
|
|
|
Hi,
u ll have to use Javascript alert functiom
hope this works.
Nitin...
|
|
|
|
|
Ok then if i may ask how do you call a javascript function (alert) from within VB code.???
|
|
|
|
|
hi,
Response.Write("<script lang=""javascript"">alert('Nitin')</script>")
hope this works
Nitin..
|
|
|
|
|
You really should use registerclientscriptblock to insert jscript. If I get you right, you're saying do a postback, if the values are outside the range, insert the script so that the posted back page shows a popup message ? It would be easier to use validation controls that generate teh script and run without postback.
Christian Graus - Microsoft MVP - C++
Metal Musings - Rex and my new metal blog
|
|
|
|
|
Thank you very much!!! It works!!!!
Just one last question? I know I'm becoming annoying - hehe
Is there a way to preserve the items in the background?
My app is fairly mature so I hay have inadvertently changed something that cases this phenomenon
The MSGBOX displays but there is a completely blank page behind it until you click ok at which stage it returns to normal.
Thanx once again
|
|
|
|
|
What you want to do is use a validation control, this can generate the javascript to check the values on the client, and pop up a message box. You need to also check on the server, if there's a chance your client page could be hacked.
Christian Graus - Microsoft MVP - C++
Metal Musings - Rex and my new metal blog
|
|
|
|
|
in my vb.net project
i have a requirement to open a word file which contain formated text ,tables,images
i can open it in a rich text box or pannel or in any way but the area allocated to me half the screen onely
i dont know how to open it in
vb.net
can any one help me
mail me at rajesh.batchu@cesltd.com
|
|
|
|
|
hi,
I want to know if there is a way to change the type of a Column in DatagridView at run time. And if so, how?
Thanks in advance
|
|
|
|
|
Once the column is created, you cannot change it's type. You have to remove the column(s), then create your own and add them to the Columns collection. It would probably be a good idea to create your own columns for each column you want to display:
Private Sub SetupDGVAndBind()
DataGridView1.Columns.Clear()
Dim col As New DataGridViewTextBoxColumn
col.HeaderText = "headerText"
col.DataPropertyName = "columnName in table"
DataGridView1.Columns.Add(col)
DataGridView1.DataSource = myBindingSource
End Sub
Dave Kreskowiak
Microsoft MVP - Visual Basic
|
|
|
|
|
Hello,
I have some (more than once) COM-Servers (in different DLL's) and each of them implements the same Interface. Only what I know is the InterfaceName and the ProgID of the COM-Server.
How can I instanciate a COM-Object in VB.NET with this informations? I C/C++ it looks like:
HRESULT hr = CLSIDFromProgID (ProgID), &clsid);
hr = CoCreateInstance (clsid, NULL, CLSCTX_INPROC_SERVER, IID_IInterfaceName, (void **) &m_pCOMSmartPtr);
\\\| \\ - -
( @ @ )
+---------------oOOo-(_)-oOOo-----------------+
| Stephan Pilz stephan.pilz@stephan-pilz.de |
| <a href=www.stephan-pilz.de>www.stephan-pilz.de</a> |
| ICQ#: 127823481 |
+-----------------------Oooo------------------+
oooO ( )
( ) ) /
\ ( (_/
\_)
|
|
|
|
|
Does something like this work for you?
Dim t As Type = Type.GetTypeFromProgID("progID")
Dim retVal As Object
retVal = Activator.CreateInstance(t)
Dave Kreskowiak
Microsoft MVP - Visual Basic
|
|
|
|
|
Hello Dave,
Yes this works fine. Thank you.
Regards
Stephan
\\\| \\ - -
( @ @ )
+---------------oOOo-(_)-oOOo-----------------+
| Stephan Pilz stephan.pilz@stephan-pilz.de |
| <a href=www.stephan-pilz.de>www.stephan-pilz.de</a> |
| ICQ#: 127823481 |
+-----------------------Oooo------------------+
oooO ( )
( ) ) /
\ ( (_/
\_)
|
|
|
|
|
No problem! 
Dave Kreskowiak
Microsoft MVP - Visual Basic
|
|
|
|
|
i convert my project atm in vb6 to vb.net but i am having error... app error! can someone help me???
asa
|
|
|
|
|
Would you care to explain what the problem is, or should we just guess?
Dave Kreskowiak
Microsoft MVP - Visual Basic
|
|
|
|
|
As Dave said, we can't guess your problem if you won't tell us. VB.NET is very different to VB6 and the upgrade wizard is not perfect, it's no surprise you have errors.
Christian Graus - Microsoft MVP - C++
Metal Musings - Rex and my new metal blog
|
|
|
|
|
With reference to my this post ....
http://www.codeproject.com/script/comments/forums.asp?msg=1676656&forumid=1646&mode=all&userid=2124480#xx1676656xx
can any one help me out with GETJOB API ??
"hay Dave is it you again answering this??" 
"You can do any thing you set to your mind" - theGhost_k8
|
|
|
|
|
The code you already have will work, so long as the machines are patched up to current levels...
Visit http://update.microsoft.com[^]. I can't make it any clearer than that.
Dave Kreskowiak
Microsoft MVP - Visual Basic
|
|
|
|
|
Hi All
I need help to convert the following code to either VB.NET or C#
I will pay $ for anyone who is willing to do this for me, as my Pascal knowledge is very limited and I am restricted with time. I need this urgently for a project I am working on. I also have the code available in C if it will help, or is easier for someone to convert.
Many thanks
Here is the pascal code:
Unit LZH;
{$A+,B-,D-,E-,F-,I+,L-,N-,O-,R-,S-,V-}
(*
* LZHUF.C English version 1.0
* Based on Japanese version 29-NOV-1988
* LZSS coded by Haruhiko OKUMURA
* Adaptive Huffman Coding coded by Haruyasu YOSHIZAKI
* Edited and translated to English by Kenji RIKITAKE
* Translated from C to Turbo Pascal by Douglas Webb 2/18/91
* Update and bug correction of TP version 4/29/91 (Sorry!!)
*)
{
This Unit allows the user to commpress data using a combination of
LZSS Compression and adaptive Huffman coding, or conversely to deCompress
data that was previously Compressed by this Unit.
There are a number of options as to where the data being Compressed/
deCompressed is coming from/going to.
In fact it requires that you pass the "LZHPack" Procedure 2 procedural
parameter of Type 'GetProcType' and 'PutProcType' (declared below) which
will accept 3 parameters and act in every way like a 'BlockRead'/'BlockWrite'
Procedure call. Your 'GetProcType' Procedure should return the data
to be Compressed, and Your 'PutProcType' Procedure should do something with
the Compressed data (ie., put it in a File). In Case you need to know (and
you do if you want to deCompress this data again) the number of Bytes in the
Compressed data (original, not Compressed size) is returned in 'Bytes_Written'.
GetBytesProc = Procedure(Var DTA; NBytes:Word; Var Bytes_Got : Word);
DTA is the start of a memory location where the inFormation returned should
be. NBytes is the number of Bytes requested. The actual number of Bytes
returned must be passed in Bytes_Got (if there is no more data then 0
should be returned).
PutBytesProc = Procedure(Var DTA; NBytes:Word; Var Bytes_Got : Word);
As above except instead of asking For data the Procedure is dumping out
Compressed data, do somthing With it.
"LZHUnPack" is basically the same thing in reverse. It requires
procedural parameters of Type 'PutProcType'/'GetProcType' which
will act as above. 'GetProcType' must retrieve data Compressed using
"LZHPack" (above) and feed it to the unpacking routine as requested.
'PutProcType' must accept the deCompressed data and do something
withit. You must also pass in the original size of the deCompressed data,
failure to do so will have adverse results.
Don't Forget that as procedural parameters the 'GetProcType'/'PutProcType'
Procedures must be Compiled in the 'F+' state to avoid a catastrophe.
}
{ note: All the large data structures For these routines are allocated when
needed from the heap, and deallocated when finished. So when not in use
memory requirements are minimal. However, this Unit Uses about 34K of
heap space, and 400 Bytes of stack when in use. }
Interface
Type
PutBytesProc = Procedure(Var DTA; NBytes : Word; Var Bytes_Put : Word);
GetBytesProc = Procedure(Var DTA; NBytes : Word; Var Bytes_Got : Word);
Procedure LZHPack(Var Bytes_Written : LongInt;
GetBytes : GetBytesProc;
PutBytes : PutBytesProc);
Procedure LZHUnpack(TextSize : LongInt;
GetBytes : GetBytesProc;
PutBytes : PutBytesProc);
Implementation
Const
Exit_OK = 0;
Exit_FAILED = 1;
{ LZSS Parameters }
N = 4096; { Size of String buffer }
F = 60; { Size of look-ahead buffer }
THRESHOLD = 2;
NUL = N; { end of tree's node }
{ Huffman coding parameters }
N_Char = (256 - THRESHOLD + F);
{ Character code (:= 0..N_Char-1) }
T = (N_Char * 2 - 1); { Size of table }
R = (T - 1); { root position }
{ update when cumulative frequency }
{ reaches to this value }
MAX_FREQ = $8000;
{
* Tables For encoding/decoding upper 6 bits of
* sliding dictionary Pointer
}
{ encoder table }
p_len : Array[0..63] of Byte =
($03, $04, $04, $04, $05, $05, $05, $05,
$05, $05, $05, $05, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$08, $08, $08, $08, $08, $08, $08, $08,
$08, $08, $08, $08, $08, $08, $08, $08);
p_code : Array[0..63] of Byte =
($00, $20, $30, $40, $50, $58, $60, $68,
$70, $78, $80, $88, $90, $94, $98, $9C,
$A0, $A4, $A8, $AC, $B0, $B4, $B8, $BC,
$C0, $C2, $C4, $C6, $C8, $CA, $CC, $CE,
$D0, $D2, $D4, $D6, $D8, $DA, $DC, $DE,
$E0, $E2, $E4, $E6, $E8, $EA, $EC, $EE,
$F0, $F1, $F2, $F3, $F4, $F5, $F6, $F7,
$F8, $F9, $FA, $FB, $FC, $FD, $FE, $FF);
{ decoder table }
d_code : Array[0..255] of Byte =
($00, $00, $00, $00, $00, $00, $00, $00,
$00, $00, $00, $00, $00, $00, $00, $00,
$00, $00, $00, $00, $00, $00, $00, $00,
$00, $00, $00, $00, $00, $00, $00, $00,
$01, $01, $01, $01, $01, $01, $01, $01,
$01, $01, $01, $01, $01, $01, $01, $01,
$02, $02, $02, $02, $02, $02, $02, $02,
$02, $02, $02, $02, $02, $02, $02, $02,
$03, $03, $03, $03, $03, $03, $03, $03,
$03, $03, $03, $03, $03, $03, $03, $03,
$04, $04, $04, $04, $04, $04, $04, $04,
$05, $05, $05, $05, $05, $05, $05, $05,
$06, $06, $06, $06, $06, $06, $06, $06,
$07, $07, $07, $07, $07, $07, $07, $07,
$08, $08, $08, $08, $08, $08, $08, $08,
$09, $09, $09, $09, $09, $09, $09, $09,
$0A, $0A, $0A, $0A, $0A, $0A, $0A, $0A,
$0B, $0B, $0B, $0B, $0B, $0B, $0B, $0B,
$0C, $0C, $0C, $0C, $0D, $0D, $0D, $0D,
$0E, $0E, $0E, $0E, $0F, $0F, $0F, $0F,
$10, $10, $10, $10, $11, $11, $11, $11,
$12, $12, $12, $12, $13, $13, $13, $13,
$14, $14, $14, $14, $15, $15, $15, $15,
$16, $16, $16, $16, $17, $17, $17, $17,
$18, $18, $19, $19, $1A, $1A, $1B, $1B,
$1C, $1C, $1D, $1D, $1E, $1E, $1F, $1F,
$20, $20, $21, $21, $22, $22, $23, $23,
$24, $24, $25, $25, $26, $26, $27, $27,
$28, $28, $29, $29, $2A, $2A, $2B, $2B,
$2C, $2C, $2D, $2D, $2E, $2E, $2F, $2F,
$30, $31, $32, $33, $34, $35, $36, $37,
$38, $39, $3A, $3B, $3C, $3D, $3E, $3F);
d_len : Array[0..255] of Byte =
($03, $03, $03, $03, $03, $03, $03, $03,
$03, $03, $03, $03, $03, $03, $03, $03,
$03, $03, $03, $03, $03, $03, $03, $03,
$03, $03, $03, $03, $03, $03, $03, $03,
$04, $04, $04, $04, $04, $04, $04, $04,
$04, $04, $04, $04, $04, $04, $04, $04,
$04, $04, $04, $04, $04, $04, $04, $04,
$04, $04, $04, $04, $04, $04, $04, $04,
$04, $04, $04, $04, $04, $04, $04, $04,
$04, $04, $04, $04, $04, $04, $04, $04,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$06, $06, $06, $06, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$08, $08, $08, $08, $08, $08, $08, $08,
$08, $08, $08, $08, $08, $08, $08, $08);
getbuf : Word = 0;
getlen : Byte = 0;
putlen : Byte = 0;
putbuf : Word = 0;
TextSize : LongInt = 0;
codesize : LongInt = 0;
printcount : LongInt = 0;
match_position : Integer = 0;
match_length : Integer = 0;
Type
FreqType = Array[0..T] of Word;
FreqPtr = ^FreqType;
PntrType = Array[0..pred(T + N_Char)] of Integer;
pntrPtr = ^PntrType;
SonType = Array[0..pred(T)] of Integer;
SonPtr = ^SonType;
TextBufType = Array[0..N + F - 2] of Byte;
TBufPtr = ^TextBufType;
WordRay = Array[0..N] of Integer;
WordRayPtr = ^WordRay;
BWordRay = Array[0..N + 256] of Integer;
BWordRayPtr = ^BWordRay;
Var
Text_buf : TBufPtr;
lson, dad : WordRayPtr;
rson : BWordRayPtr;
freq : FreqPtr; { cumulative freq table }
{
* pointing parent nodes.
* area [T..(T + N_Char - 1)] are Pointers For leaves
}
prnt : pntrPtr;
{ pointing children nodes (son[], son[] + 1)}
son : SonPtr;
Procedure InitTree; { Initializing tree }
Var
i : Integer;
begin
For i := N + 1 to N + 256 do
rson^[i] := NUL; { root }
For i := 0 to N do
dad^[i] := NUL; { node }
end;
Procedure InsertNode(R : Integer); { Inserting node to the tree }
Var
tmp, i, p, cmp : Integer;
key : TBufPtr;
c : Word;
begin
cmp := 1;
key := @Text_buf^[R];
p := succ(N) + key^[0];
rson^[R] := NUL;
lson^[R] := NUL;
match_length := 0;
While match_length < F do
begin
if (cmp >= 0) then
begin
if (rson^[p] <> NUL) then
p := rson^[p]
else
begin
rson^[p] := R;
dad^[R] := p;
Exit;
end;
end
else
begin
if (lson^[p] <> NUL) then
p := lson^[p]
else
begin
lson^[p] := R;
dad^[R] := p;
Exit;
end;
end;
i := 0;
cmp := 0;
While (i < F) and (cmp = 0) do
begin
inc(i);
cmp := key^[i] - Text_buf^[p + i];
end;
if (i > THRESHOLD) then
begin
tmp := pred((R - p) and pred(N));
if (i > match_length) then
begin
match_position := tmp;
match_length := i;
end;
if (match_length < F) and (i = match_length) then
begin
c := tmp;
if (c < match_position) then
match_position := c;
end;
end;
end; { While True do }
dad^[R] := dad^[p];
lson^[R] := lson^[p];
rson^[R] := rson^[p];
dad^[lson^[p]] := R;
dad^[rson^[p]] := R;
if (rson^[dad^[p]] = p) then
rson^[dad^[p]] := R
else
lson^[dad^[p]] := R;
dad^[p] := NUL; { remove p }
end;
Procedure DeleteNode(p : Integer); { Deleting node from the tree }
Var
q : Integer;
begin
if (dad^[p] = NUL) then
Exit; { unregistered }
if (rson^[p] = NUL) then
q := lson^[p]
else if (lson^[p] = NUL) then
q := rson^[p]
else
begin
q := lson^[p];
if (rson^[q] <> NUL) then
begin
Repeat
q := rson^[q];
Until (rson^[q] = NUL);
rson^[dad^[q]] := lson^[q];
dad^[lson^[q]] := dad^[q];
lson^[q] := lson^[p];
dad^[lson^[p]] := q;
end;
rson^[q] := rson^[p];
dad^[rson^[p]] := q;
end;
dad^[q] := dad^[p];
if (rson^[dad^[p]] = p) then
rson^[dad^[p]] := q
else
lson^[dad^[p]] := q;
dad^[p] := NUL;
end;
{ Huffman coding parameters }
Function GetBit(GetBytes : GetBytesProc) : Integer; { get one bit }
Var
i : Byte;
i2 : Integer;
result : Word;
begin
While (getlen <= 8) do
begin
GetBytes(i, 1, result);
if result = 1 then
i2 := i
else i2 := 0;
getbuf := getbuf or (i2 shl (8 - getlen));
inc(getlen, 8);
end;
i2 := getbuf;
getbuf := getbuf shl 1;
dec(getlen);
GetBit := Integer((i2 < 0));
end;
Function GetByte(GetBytes : GetBytesProc) : Integer; { get a Byte }
Var
j : Byte;
i, result : Word;
begin
While (getlen <= 8) do
begin
GetBytes(j, 1, result);
if result = 1 then
i := j
else
i := 0;
getbuf := getbuf or (i shl (8 - getlen));
inc(getlen, 8);
end;
i := getbuf;
getbuf := getbuf shl 8;
dec(getlen, 8);
GetByte := Integer(i shr 8);
end;
Procedure Putcode(l : Integer; c : Word;
PutBytes : PutBytesProc); { output c bits }
Var
Temp : Byte;
Got : Word;
begin
putbuf := putbuf or (c shr putlen);
inc(putlen, l);
if (putlen >= 8) then
begin
Temp := putbuf shr 8;
PutBytes(Temp, 1, Got);
dec(putlen, 8);
if (putlen >= 8) then
begin
Temp := lo(putbuf);
PutBytes(Temp, 1, Got);
inc(codesize, 2);
dec(putlen, 8);
putbuf := c shl (l - putlen);
end
else
begin
putbuf := putbuf shl 8;
inc(codesize);
end;
end;
end;
{ initialize freq tree }
Procedure StartHuff;
Var
i, j : Integer;
begin
For i := 0 to pred(N_Char) do
begin
freq^[i] := 1;
son^[i] := i + T;
prnt^[i + T] := i;
end;
i := 0;
j := N_Char;
While (j <= R) do
begin
freq^[j] := freq^[i] + freq^[i + 1];
son^[j] := i;
prnt^[i] := j;
prnt^[i + 1] := j;
inc(i, 2);
inc(j);
end;
freq^[T] := $ffff;
prnt^[R] := 0;
end;
{ reConstruct freq tree }
Procedure reConst;
Var
i, j, k, tmp : Integer;
F, l : Word;
begin
{ halven cumulative freq For leaf nodes }
j := 0;
For i := 0 to pred(T) do
begin
if (son^[i] >= T) then
begin
freq^[j] := succ(freq^[i]) div 2; {@@ Bug Fix MOD -> div @@}
son^[j] := son^[i];
inc(j);
end;
end;
{ make a tree : first, connect children nodes }
i := 0;
j := N_Char;
While (j < T) do
begin
k := succ(i);
F := freq^[i] + freq^[k];
freq^[j] := F;
k := pred(j);
While F < freq^[k] do
dec(k);
inc(k);
l := (j - k) shl 1;
tmp := succ(k);
move(freq^[k], freq^[tmp], l);
freq^[k] := F;
move(son^[k], son^[tmp], l);
son^[k] := i;
inc(i, 2);
inc(j);
end;
{ connect parent nodes }
For i := 0 to pred(T) do
begin
k := son^[i];
if (k >= T) then
begin
prnt^[k] := i;
end
else
begin
prnt^[k] := i;
prnt^[succ(k)] := i;
end;
end;
end;
{ update freq tree }
Procedure update(c : Integer);
Var
i, j, k, l : Integer;
begin
if (freq^[R] = MAX_FREQ) then
begin
reConst;
end;
c := prnt^[c + T];
Repeat
inc(freq^[c]);
k := freq^[c];
{ swap nodes to keep the tree freq-ordered }
l := succ(c);
if (k > freq^[l]) then
begin
While (k > freq^[l]) do
inc(l);
dec(l);
freq^[c] := freq^[l];
freq^[l] := k;
i := son^[c];
prnt^[i] := l;
if (i < T) then prnt^[succ(i)] := l;
j := son^[l];
son^[l] := i;
prnt^[j] := c;
if (j < T) then prnt^[succ(j)] := c;
son^[c] := j;
c := l;
end;
c := prnt^[c];
Until (c = 0); { Repeat it Until reaching the root }
end;
Var
code, len : Word;
Procedure EncodeChar(c : Word; PutBytes : PutBytesProc);
Var
i : Word;
j, k : Integer;
begin
i := 0;
j := 0;
k := prnt^[c + T];
{ search connections from leaf node to the root }
Repeat
i := i shr 1;
{
if node's address is odd, output 1
else output 0
}
if Boolean(k and 1) then inc(i, $8000);
inc(j);
k := prnt^[k];
Until (k = R);
Putcode(j, i, PutBytes);
code := i;
len := j;
update(c);
end;
Procedure EncodePosition(c : Word; PutBytes : PutBytesProc);
Var
i, j : Word;
begin
{ output upper 6 bits With encoding }
i := c shr 6;
j := p_code[i];
Putcode(p_len[i], j shl 8, PutBytes);
{ output lower 6 bits directly }
Putcode(6, (c and $3f) shl 10, PutBytes);
end;
Procedure Encodeend(PutBytes : PutBytesProc);
Var
Temp : Byte;
Got : Word;
begin
if Boolean(putlen) then
begin
Temp := lo(putbuf shr 8);
PutBytes(Temp, 1, Got);
inc(codesize);
end;
end;
Function DecodeChar(GetBytes : GetBytesProc) : Integer;
Var
c : Word;
begin
c := son^[R];
{
* start searching tree from the root to leaves.
* choose node #(son[]) if input bit = 0
* else choose #(son[]+1) (input bit = 1)
}
While (c < T) do
begin
c := c + GetBit(GetBytes);
c := son^[c];
end;
c := c - T;
update(c);
DecodeChar := Integer(c);
end;
Function DecodePosition(GetBytes : GetBytesProc) : Word;
Var
i, j, c : Word;
begin
{ decode upper 6 bits from given table }
i := GetByte(GetBytes);
c := Word(d_code[i] shl 6);
j := d_len[i];
{ input lower 6 bits directly }
dec(j, 2);
While j <> 0 do
begin
i := (i shl 1) + GetBit(GetBytes);
dec(j);
end;
DecodePosition := c or i and $3f;
end;
{ Compression }
Procedure InitLZH;
begin
getbuf := 0;
getlen := 0;
putlen := 0;
putbuf := 0;
TextSize := 0;
codesize := 0;
printcount := 0;
match_position := 0;
match_length := 0;
new(lson);
new(dad);
new(rson);
new(Text_buf);
new(freq);
new(prnt);
new(son);
end;
Procedure endLZH;
begin
dispose(son);
dispose(prnt);
dispose(freq);
dispose(Text_buf);
dispose(rson);
dispose(dad);
dispose(lson);
end;
Procedure LZHPack(Var Bytes_Written : LongInt;
GetBytes : GetBytesProc;
PutBytes : PutBytesProc);
Var
ct : Byte;
i, len, R, s, last_match_length : Integer;
Got : Word;
begin
InitLZH;
TextSize := 0; { rewind and rescan }
StartHuff;
InitTree;
s := 0;
R := N - F;
fillChar(Text_buf^[0], R, ' ');
len := 0;
Got := 1;
While (len < F) and (Got <> 0) do
begin
GetBytes(ct, 1, Got);
if Got <> 0 then
begin
Text_buf^[R + len] := ct;
inc(len);
end;
end;
TextSize := len;
For i := 1 to F do
InsertNode(R - i);
InsertNode(R);
Repeat
if (match_length > len) then
match_length := len;
if (match_length <= THRESHOLD) then
begin
match_length := 1;
EncodeChar(Text_buf^[R], PutBytes);
end
else
begin
EncodeChar(255 - THRESHOLD + match_length, PutBytes);
EncodePosition(match_position, PutBytes);
end;
last_match_length := match_length;
i := 0;
Got := 1;
While (i < last_match_length) and (Got <> 0) do
begin
GetBytes(ct, 1, Got);
if Got <> 0 then
begin
DeleteNode(s);
Text_buf^[s] := ct;
if (s < pred(F)) then
Text_buf^[s + N] := ct;
s := succ(s) and pred(N);
R := succ(R) and pred(N);
InsertNode(R);
inc(i);
end;
end;
inc(TextSize, i);
While (i < last_match_length) do
begin
inc(i);
DeleteNode(s);
s := succ(s) and pred(N);
R := succ(R) and pred(N);
dec(len);
if Boolean(len) then InsertNode(R);
end;
Until (len <= 0);
Encodeend(PutBytes);
endLZH;
Bytes_Written := TextSize;
end;
Procedure LZHUnpack(TextSize : LongInt;
GetBytes : GetBytesProc;
PutBytes : PutBytesProc);
Var
c, i, j, k, R : Integer;
c2, a : Byte;
count : LongInt;
Put : Word;
begin
InitLZH;
StartHuff;
R := N - F;
fillChar(Text_buf^[0], R, ' ');
count := 0;
While count < TextSize do
begin
c := DecodeChar(GetBytes);
if (c < 256) then
begin
c2 := lo(c);
PutBytes(c2, 1, Put);
Text_buf^[R] := c;
inc(R);
R := R and pred(N);
inc(count);
end
else
begin
i := (R - succ(DecodePosition(GetBytes))) and pred(N);
j := c - 255 + THRESHOLD;
For k := 0 to pred(j) do
begin
c := Text_buf^[(i + k) and pred(N)];
c2 := lo(c);
PutBytes(c2, 1, Put);
Text_buf^[R] := c;
inc(R);
R := R and pred(N);
inc(count);
end;
end;
end;
endLZH;
end;
end.
|
|
|
|
|
I'd put money on you finding a person to convert it from C before you do Pascal. What does it do ? Some sort of encryption ? Is it custom, or a known algorithm ? There's lots of Cryptography stuff built in to .NET.
Christian Graus - Microsoft MVP - C++
Metal Musings - Rex and my new metal blog
|
|
|
|
|
It's a compression algorithm, with Adaptive Huffman. I think the code he posted is about 15 years old!
Dave Kreskowiak
Microsoft MVP - Visual Basic
|
|
|
|
|
General 
News 
Suggestion 
Question 
Bug 
Answer 
Joke 
Praise 
Rant 
Admin 
Submit an article or tip
