不会啊, 我刚才还试了一下, 里面有个控件需要先安上..再说了, 你只要看一部分
源代码就可以了
unit UWriteForm;
(* 彂偒崬傒夋柺 *)
(* Copyright (c) 2001,2002 Twiddle <hetareprog@hotmail.com> *)
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
ComCtrls,
StdCtrls,
DateUtils,
ActnList,
Menus,
{$IFDEF IE}
OleCtrls,
SHDocVw_TLB,
MSHTML_TLB,
{$ELSE}
HogeTextView,
UTVSub,
{$ENDIF}
StrUtils,
IniFiles,
U2chThread,
U2chBoard,
HTTPSub,
IdBaseComponent,
IdComponent,
IdTCPConnection,
IdTCPClient,
IdHTTP,
JConfig,
UDat2HTML,
UViewItem,
UAsync,
UXTime,
U2chTicket,
ULocalCopy,
StrSub,
jconvert;
type
TPostType = (postNormal, postCheck);
TFormType = (formWrite, formBuild);
TWriteForm = class(TForm)
PageControl: TPageControl;
TabSheet1: TTabSheet;
Panel1: TPanel;
TabSheetLocalRule: TTabSheet;
EditNameBox: TComboBox;
Label1: TLabel;
Label2: TLabel;
EditMailBox: TComboBox;
CheckBoxSage: TCheckBox;
Memo: TMemo;
Panel2: TPanel;
Panel3: TPanel;
ButtonWrite: TButton;
ButtonCancel: TButton;
TabSheet3: TTabSheet;
Result: TMemo;
ThreadTitlePanel: TPanel;
RecordCheckBox: TCheckBox;
CheckBoxTop: TCheckBox;
EditSubjectBox: TEdit;
TitleLabel: TLabel;
SubjectPanel: TPanel;
Panel4: TPanel;
ActionList: TActionList;
writeActWrite: TAction;
writeActCancel: TAction;
procedure PageControlChange(Sender: TObject);
procedure CheckBoxSageClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormDeactivate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure ButtonCancelClick(Sender: TObject);
procedure ButtonWriteClick(Sender: TObject);
procedure FormHide(Sender: TObject);
procedure FormDestroy(Sender: TObject);
function Hook(var Message: TMessage): Boolean;
procedure FormShortCut(var Msg: TWMKey; var Handled: Boolean);
procedure MemoKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure RecordCheckBoxClick(Sender: TObject); //521
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CheckBoxTopClick(Sender: TObject);
private
{ Private 愰尵 }
savedTop : integer;
savedLeft : integer;
savedWidth: integer;
savedHeight: integer;
gotRule: TProgState;
procGet: TAsyncReq;
procPost: TAsyncReq;
storedRule: TLocalCopy;
writeRetryCount: Integer;
cookieRetryCount: Integer;
postType: TPostType;
postCode: string;
kakikomiFile: TFileStream;
formType: TFormType;
FtimeValue: Int64;
{$IFDEF IE}
WebBrowser: TWebBrowser;
{$ELSE}
TextView: THogeTextView;
{$ENDIF}
procedure PostArticle;
procedure GetLocalRule;
procedure OnNotify(sender: TAsyncReq; code: TAsyncNotifyCode);
procedure OnWritten(sender: TAsyncReq);
procedure OnLocalRule(sender: TAsyncReq);
{$IFDEF IE}
procedure WebBrowserDocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
procedure WebBrowserBeforeNavigate2(Sender: TObject;
const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
{$ELSE}
procedure OnBrowserMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
procedure OnBrowserMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
{$ENDIF}
procedure BeforeNavigate(const URL: String; var Cancel: WordBool);
procedure RequestToGetLocalRule;
protected
//procedure ON_WM_ACTIVATE (var msg: TWMActivate); message WM_ACTIVATE;
procedure ON_WM_NCLBUTTONDOWN(var Msg: TMsg); message WM_NCLBUTTONDOWN;
procedure CreateParams(var Params: TCreateParams); override;
public
{ Public 愰尵 }
freeReserve: boolean; //愝掕曄峏斀塮梡偺夝曻梊栺
thread: TThreadItem;
board: TBoard;
procedure Show(threadItem: TThreadItem); overload;
procedure Show(boardItem: TBoard); overload;
end;
var
WriteForm: TWriteForm;
(*=======================================================*)
implementation
(*=======================================================*)
uses
Main, IdCookie;
{$R *.dfm}
(* 儘乕僇儖儖乕儖庢摼僉僢僋 *)
procedure TWriteForm.PageControlChange(Sender: TObject);
begin
(* *)
if PageControl.ActivePageIndex = 1 then
GetLocalRule;
end;
(* 憢傪僞僗僋僶乕偵 *)
procedure TWriteForm.CreateParams(var Params: TCreateParams);
begin
inherited;
if FormStyle in [fsNormal, fsStayOnTop] then
if BorderStyle in [bsSingle, bsSizeable] then
if Config.wrtFmUseTaskBar then
begin
Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;
Params.WndParent := 0;
end else
Params.ExStyle := Params.ExStyle and not WS_EX_APPWINDOW;
end;
(* 暵偠偨帪偺張棟 *)
procedure TWriteForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
WriteForm := nil;
end;
(* 憢傪嵟慜柺偵 *)
procedure TWriteForm.CheckBoxTopClick(Sender: TObject);
begin
Config.wrtFormStayOnTop := CheckBoxTop.Checked;
if CheckBoxTop.Checked then
FormStyle := fsStayOnTop
else
FormStyle := fsNormal;
end;
(* SAGE張棟 *)
procedure TWriteForm.CheckBoxSageClick(Sender: TObject);
begin
if CheckBoxSage.Checked then
begin
EditMailBox.Text := 'sage';
EditMailBox.Enabled := false;
end
else begin
EditMailBox.Text := '';
EditMailBox.Enabled := true;
end;
end;
(* 柤慜丒儊乕儖婰壇僠僃僢僋 *)//521
procedure TWriteForm.RecordCheckBoxClick(Sender: TObject);
begin
Config.wrtRecordNameMail := RecordCheckBox.checked;
end;
(* 弶婜壔 *)
procedure TWriteForm.FormCreate(Sender: TObject);
procedure KeyConf;
var
ini: TIniFile;
i: integer;
procedure SetShortCut(action: TAction);
var
key: string;
begin
key := ini.ReadString('KEY', action.Name, '');
if key = '' then
exit;
action.ShortCut := TextToShortCut(key);
if (action.ShortCut = 0) and (length(key) > 1)then
try
action.ShortCut := StrToInt(key);
except
end;
end;
begin
if not FileExists(Config.BasePath + KEYCONF_FILE) then
exit;
ini := TIniFile.Create(Config.BasePath + KEYCONF_FILE);
for i := 0 to ActionList.ActionCount -1 do
SetShortCut(TAction(ActionList.Actions));
ini.Free;
end;
var
font: TFont;
begin
savedLeft := 0;
savedTop := 0;
savedWidth := 0;
savedHeight := 0;
writeRetryCount := 0;
cookieRetryCount := 0;
postType := postNormal;
postCode := '';
board := nil;
thread := nil;
procGet := nil;
procPost := nil;
{$IFDEF IE}
WebBrowser := TWebBrowser.Create(TabSheetLocalRule);
TOleControl(WebBrowser).Parent := TabSheetLocalRule;
with WebBrowser do
begin
Align := alClient;
OnBeforeNavigate2 := WebBrowserBeforeNavigate2;
OnDocumentComplete := WebBrowserDocumentComplete;
end;
{$ELSE}
TextView := THogeTextView.Create(TabSheetLocalRule);
with TextView do
begin
Parent := TabSheetLocalRule;
Align := alClient;
Enabled := True;
Visible := True;
TabStop := True;
LeftMargin := 8;
TopMargin := 4;
RightMargin := 8;
ExternalLeading := 1;
VerticalCaretMargin := 1;
VScrollLines := 5;
TextAttrib[1].style := [fsBold];
TextAttrib[2].color := clBlue;
TextAttrib[2].style := [fsUnderline];
TextAttrib[3].color := clBlue;
TextAttrib[3].style := [fsBold, fsUnderline];
TextAttrib[4].color := clRed;
TextAttrib[5].color := clGreen;
OnMouseMove := OnBrowserMouseMove;
OnMouseDown := OnBrowserMouseDown;
end;
{$ENDIF}
if Config.viewDefFontInfo.face <> '' then
begin
font := TFont.Create;
Config.SetFont(font, Config.viewDefFontInfo);
Self.Font.Assign(font);
font.Free;
end;
if Config.viewWriteFontInfo.face <> '' then
begin
font := TFont.Create;
Config.SetFont(font, Config.viewWriteFontInfo);
Memo.Font.Assign(font);
font.Free;
end;
//仸[457]
ThreadTitlePanel.Color := MainWnd.ThreadToolPanel.Color;
ThreadTitlePanel.Font := MainWnd.ThreadTitleLabel.Font;
storedRule := nil;
//仴儊僀儞僂傿儞僪僂偺僔儑乕僩僇僢僩傪柍岠壔
Application.HookMainWindow(hook);
KeyConf;
CheckBoxTop.Enabled := Config.wrtFmUseTaskBar;
EditNameBox.Items := Config.wrtNameList;
EditMailBox.Items := Config.wrtMailList;
freeReserve := false;
end;
(* [嵞]昞帵帪 *)
procedure TWriteForm.FormActivate(Sender: TObject);
begin
if 0 < savedWidth then
Width := savedWidth;
if 0 < savedHeight then
Height := savedHeight;
//仴儗僗僂傿儞僪僂傾僋僥傿僽帪偵IME桳岠壔
SetImeMode(Handle, userImeMode);
end;
(* 幾杺偵側傜側偄傛偆偵偡傞 *)
procedure TWriteForm.FormDeactivate(Sender: TObject);
begin
savedLeft := Left;
savedTop := Top;
savedWidth:= Width;
savedHeight:= Height;
if not Config.wrtFmUseTaskBar then
Height := 10;
//仴儗僗僂傿儞僪僂偐傜僼僅乕僇僗偑奜傟傞偲偒偵IME忬懺傪曐懚
SaveImeMode(Handle);
end;
{procedure TWriteForm.ON_WM_ACTIVATE (var msg: TWMActivate);
begin
if not Config.wrtFmUseTaskBar then
if msg.Active = WA_INACTIVE then
begin
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE or SWP_NOACTIVATE);
end
else begin
if (ActiveControl = nil) and not (csDesigning in ComponentState) then
ActiveControl := FindNextControl(nil, True, True, False);
SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE or SWP_NOACTIVATE);
end;
end;}
(* 彂偒崬傒帪偵IME偑棤偵夞傞栤戣偺懳嶔 偐側傝嬯偟傔 *)
procedure TWriteForm.ON_WM_NCLBUTTONDOWN(var Msg: TMsg);
begin
if not Config.wrtFmUseTaskBar and
(userImeMode <> imClose) and //IME偑僆乕僾儞(偵側傞梊掕)偱
//憢偑旕傾僋僥傿僽偐偮傾僋僥傿僽偵側傟偽Memo偵僼僅乕僇僗傪堏偡偲偒
not Self.Active and (ActiveControl = Memo) and not Memo.Focused and
(Self.WindowState <> wsMinimized) then
Memo.SetFocus //WM_NCLBUTTONDOWN傪張棟偟側偄
else
inherited;
end;
(* 昞帵張棟 *)
procedure TWriteForm.Show(threadItem: TThreadItem);
begin
if assigned(thread) then
begin
SetFocus;
end
else begin
thread := threadItem;
thread.AddRef;
end;
formType := formWrite;
board := TBoard(thread.board);
//儗僗梡僂傿儞僪僂偺昞帵忬懺愝掕
Self.Caption := '亀' + thread.title + '亁 偵儗僗';
ThreadTitlePanel.Visible := Config.wrtShowThreadTitle;
SubjectPanel.Visible := false;
ThreadTitlePanel.Caption := '亂' + thread.GetBoardName + '亃 - ' + thread.title;
RecordCheckBox.Enabled :=true;
PageControl.ActivePageIndex := 0;
//柤慜偲儊乕儖棑
//521 婰壇偟偨Name/Mail傪儃僢僋僗傊
RecordCheckBox.checked := Config.wrtRecordNameMail;
CheckBoxSage.Checked := false;
//柤慜
if thread.UsedWriteMail <> '' then
EditNameBox.Text := thread.UsedWriteName
else if (thread.UsedWriteMail = '') and // 婰壇偝傟偰側偄僗儗(婰壇偝傟偨僗儗偵偼昁偢!偑擖傞)
Config.wrtUseDefaultName and (Config.wrtNameList.Count > 0) then
EditNameBox.Text := Config.wrtNameList[0]
else
EditNameBox.Text := '';
//儊乕儖
if thread.UsedWriteMail <> '' then
EditMailBox.Text := thread.UsedWriteMail
else if (thread.UsedWriteMail = '') and Config.wrtDefaultSageCheck then
EditMailBox.Text := 'sage'
else
EditMailBox.Text := '';
if AnsiStartsStr('!',EditMailBox.Text) then
EditMailBox.Text := Copy(EditMailBox.Text, 2, length(EditMailBox.Text) - 1);
CheckBoxTop.Checked := Config.wrtFormStayOnTop;
if Config.wrtFmUseTaskBar and not CheckBoxTop.Checked then
FormStyle := fsNormal;
inherited Show;
end;
(* 僗儗棫偰帪偺昞帵張棟 *)
procedure TWriteForm.Show(boardItem: TBoard);
begin
if assigned(board) then
begin
SetFocus;
end
else begin
board := boardItem;
end;
formType := formBuild;
thread := nil;
//僗儗棫偰梡僂傿儞僪僂偺昞帵忬懺愝掕
Self.Caption := '亂' + board.name + '亃 偵怴婯僗儗僢僪';
SubjectPanel.Visible := true;
ThreadTitlePanel.Visible := false;
EditSubjectBox.Text := '';
RecordCheckBox.Enabled :=false;
PageControl.ActivePageIndex := 1;
//柤慜偲儊乕儖棑
if (Config.wrtUseDefaultName) and (Config.wrtNameList.Count <>0) then
EditNameBox.Text := Config.wrtNameList[0]
else
EditNameBox.Text := '';
if Config.wrtDefaultSageCheck then
EditMailBox.Text := 'sage'
else
EditMailBox.Text := '';
CheckBoxTop.Checked := Config.wrtFormStayOnTop;
if Config.wrtFmUseTaskBar and not CheckBoxTop.Checked then
FormStyle := fsNormal;
inherited Show;
end;
(* 昞帵帪張棟 *)
procedure TWriteForm.FormShow(Sender: TObject);
begin
//儗僗丒僗儗棫偰嫟捠
if EditMailBox.Text = 'sage' then
begin
EditMailBox.Enabled := false;
CheckBoxSage.Checked := true;
end
else begin
EditMailBox.Enabled := true;
CheckBoxSage.Checked := false;
end;
ButtonWrite.Enabled := true;
PageControl.Pages[2].TabVisible := (procPost <> nil);
gotRule := tpsNone;
postType := postNormal;
postCode := '';
//仸[JS]
if Memo.CanFocus then
Memo.SetFocus;
if PageControl.ActivePageIndex = 1 then
GetLocalRule;
end;
(* 傗傔偨張棟 *)
procedure TWriteForm.ButtonCancelClick(Sender: TObject);
begin
Visible := False;
end;
(* 僇僉僐張棟 *)
procedure TWriteForm.ButtonWriteClick(Sender: TObject);
begin
if (postType = postCheck) and Memo.Modified then
postType := postNormal;
writeRetryCount := 0;
cookieRetryCount := 0;
Result.Clear;
PostArticle;
Memo.Modified := false;
//仴僔僼僩墴偟偰偨傜儕僗僩偵捛壛
if GetKeyState(VK_SHIFT) < 0 then
begin
if Config.wrtNameList.IndexOf(EditNameBox.Text) < 0 then
begin
Config.wrtNameList.Add(EditNameBox.Text);
EditNameBox.Items := Config.wrtNameList;
end;
if not CheckBoxSage.Checked and (Config.wrtMailList.IndexOf(EditMailBox.Text) < 0) then
begin
Config.wrtMailList.Add(EditMailBox.Text);
EditMailBox.Items := Config.wrtMailList;
end;
Config.Modified := true;
end;
if formType = formWrite then
begin
Config.wrtRecordNameMail := RecordCheckBox.checked; //521 Name丒Mail偺婰壇丒嵟廔彂崬
if RecordCheckBox.checked then
begin
thread.UsedWriteName := EditNameBox.Text;
thread.UsedWriteMail := '!' + EditMailBox.Text;
thread.SaveIndexData;
end;
end;
end;
procedure TWriteForm.PostArticle;
var
URI: string;
encName, encMail: string;
postDat: string;
referer: string;
list: TStringList;
cookie: string;
begin
case board.GetBBSType of
bbs2ch:
begin
encName := URLEncode(EditNameBox.Text);
encMail := URLEncode(EditMailBox.Text);
case formType of
formWrite:
begin
case postType of
postNormal:
begin
URI := 'http://' + board.host + '/test/bbs.cgi';
postDat := 'submit=' + URLEncode('彂偒崬傓')
+ '&FROM=' + encName
+ '&mail=' + encMail
+ '&MESSAGE=' + URLEncode(Memo.Text)
+ '&bbs=' + board.bbs
+ '&key=' + ChangeFileExt(thread.datName, '')
+ '&time=' + IntToStr(timeValue);
end;
postCheck:
begin
URI := 'http://' + board.host + '/test/subbbs.cgi';
postDat := 'bbs=' + board.bbs
+ '&key=' + ChangeFileExt(thread.datName, '')
+ '&time=' + IntToStr(timeValue)
+ '&subject='
+ '&FROM=' + encName
+ '&mail=' + encMail
+ '&MESSAGE=' + URLEncode(Memo.Text)
+ '&code=' + postCode
+ '&submit=' + URLEncode('慡愑擟傪晧偆偙偲傪彸戻偟偰彂偒崬傓');
end;
end;
end;
formBuild:
begin
case postType of
postNormal:
begin
URI := 'http://' + board.host + '/test/bbs.cgi';
postDat := 'subject=' + URLEncode(EditSubjectBox.Text)
+ '&submit=' + URLEncode('怴婯僗儗僢僪嶌惉')
+ '&FROM=' + encName
+ '&mail=' + encMail
+ '&MESSAGE=' + URLEncode(Memo.Text)
+ '&bbs=' + board.bbs
+ '&time=' + IntToStr(timeValue);
end;
postCheck:
begin
URI := 'http://' + board.host + '/test/subbbs.cgi';
postDat := 'subject=' + URLEncode(EditSubjectBox.Text)
+ '&FROM=' + encName
+ '&mail=' + encMail
+ '&MESSAGE=' + URLEncode(Memo.Text)
+ '&bbs=' + board.bbs
+ '&time=' + IntToStr(timeValue)
+ '&submit=' + URLEncode('慡愑擟傪晧偆偙偲傪彸戻偟偰彂偒崬傓');
end;
end;
end;
end;
postDat := postDat + ticket2ch.GetSID(URI, '&');
end;
bbsJBBSShitaraba:
begin
encName := URLEncode(sjis2euc(EditNameBox.Text));
encMail := URLEncode(sjis2euc(EditMailBox.Text));
URI := 'http://' + board.host + '/bbs/write.cgi';
case formType of
formWrite:
begin
postDat := 'submit=' + URLEncode(sjis2euc('彂偒崬傓'))
+ '&NAME=' + encName
+ '&MAIL=' + encMail
+ '&MESSAGE=' + URLEncode(sjis2euc(Memo.Text))
+ '&BBS=' + board.bbs
+ '&KEY=' + ChangeFileExt(thread.datName, '')
+ '&TIME=' + IntToStr(UTC);
end;
formBuild:
begin
postDat := 'SUBJECT=' + URLEncode(sjis2euc(EditSubjectBox.Text))
+ '&submit=' + URLEncode(sjis2euc('怴婯彂偒崬傒'))
+ '&NAME=' + encName
+ '&MAIL=' + encMail
+ '&MESSAGE=' + URLEncode(sjis2euc(Memo.Text))
+ '&BBS=' + board.bbs
+ '&TIME=' + IntToStr(UTC);
end;
end;
end;
bbsMachi, bbsJBBS:
begin
encName := URLEncode(EditNameBox.Text);
encMail := URLEncode(EditMailBox.Text);
URI := 'http://' + board.host + '/bbs/write.cgi';
case formType of
formWrite:
begin
postDat := 'submit=' + URLEncode(sjis2euc('彂偒崬傓'))
+ '&NAME=' + encName
+ '&MAIL=' + encMail
+ '&MESSAGE=' + URLEncode(Memo.Text)
+ '&BBS=' + board.bbs
+ '&KEY=' + ChangeFileExt(thread.datName, '')
+ '&TIME=' + IntToStr(UTC);
end;
formBuild:
begin
postDat := 'SUBJECT=' + URLEncode(EditSubjectBox.Text)
+ '&submit=' + URLEncode(sjis2euc('怴婯彂偒崬傒'))
+ '&NAME=' + encName
+ '&MAIL=' + encMail
+ '&MESSAGE=' + URLEncode(Memo.Text)
+ '&BBS=' + board.bbs
+ '&TIME=' + IntToStr(UTC);
end;
end;
end;
bbsOther:
begin
encName := URLEncode(EditNameBox.Text);
encMail := URLEncode(EditMailBox.Text);
URI := 'http://' + board.host + '/test/bbs.cgi';
case formType of
formWrite:
begin
postDat := 'submit=' + URLEncode('彂偒崬傓')
+ '&FROM=' + encName
+ '&mail=' + encMail
+ '&MESSAGE=' + URLEncode(Memo.Text)
+ '&bbs=' + board.bbs
+ '&key=' + ChangeFileExt(thread.datName, '')
+ '&time=' + IntToStr(UTC);
end;
formBuild:
begin
postDat := 'subject=' + URLEncode(EditSubjectBox.Text)
+ '&submit=' + URLEncode('怴婯僗儗僢僪嶌惉')
+ '&FROM=' + encName
+ '&mail=' + encMail
+ '&MESSAGE=' + URLEncode(Memo.Text)
+ '&bbs=' + board.bbs
+ '&time=' + IntToStr(UTC);
end;
end;
end;
end;
referer := board.GetURIBase + '/';
cookie := 'Cookie: NAME=' + encName + '&MAIL=' + encMail + ';';
list := TStringList.Create;
list.Add(cookie);
if (board.GetBBSType = bbs2ch) and (0 < length(Config.tstWrtCookie)) then
begin
{if Pos('=', Config.tstWrtCookie) < 0 then
list.Add('Cookie: SPID=' + Config.tstWrtCookie + ';')
else}
list.Add('Cookie: ' + Config.tstWrtCookie);
end;
procPost := Main.AsyncManager.Post(URI, postDat, referer, list,
OnWritten, OnNotify);
if procPost <> nil then
begin
ButtonWrite.Enabled := false;
Result.Lines.Add('--------------------');
Result.Lines.Add('彂崬傒拞丒丒丒');
Result.Lines.Add('--------------------');
PageControl.Pages[2].TabVisible := true;
PageControl.ActivePageIndex := 2;
end;
list.Free;
end;
procedure TWriteForm.OnNotify(sender: TAsyncReq; code: TAsyncNotifyCode);
begin
case code of
ancPRECONNECT:
begin
ticket2ch.On2chPreConnect(sender, code);
sender.IdHTTP.AllowCookies := True;
end;
ancPRETERMINATE:
if procPost = sender then
Windows.Sleep(1000); (* 彮偟偖傜偄懸偨偣偰傒傞僥僗僩 *)
end;
end;
procedure TWriteForm.OnWritten(sender: TAsyncReq);
var
responseHTML: string;
function GetErrMsg: string;
var
errPos, limit: integer;
begin
result := '';
if responseHTML = '' then
exit;
limit := FindPosIC('<head>', responseHTML, 0);
if limit >=0 then
begin
errPos := FindPosIC('2ch_X:', responseHTML, 0, limit);
if errPos >= 0 then
begin
errPos := errPos + 6;
limit := FindPos('-->', responseHTML, errPos, limit);
result := trim(copy(responseHTML, errPos, limit - errPos));
end;
end;
end;
procedure SetPostCode;
var
codePos: integer;
begin
if responseHTML = '' then
exit;
codePos := FindPos('code value=', responseHTML, 0);
if codePos >= 0 then
begin
codePos := codePos + 11;
//仴偪傚偭偲嫮堷側code庢摼
postCode := copy(responseHTML, codePos, FindPos('>', responseHTML, codepos) - codePos);
end;
postType := postCheck;
Result.Lines.Add('--------------------');
Result.Lines.Add('妋擣偟偨傜傕偆堦搙乽彂偒崬傓乿傪墴偟偰偔偩偝偄丒丒丒');
Result.Lines.Add('--------------------');
ButtonWrite.Enabled := true;
end;
var
i: integer;
viewItem: TViewItem;
responseText: string;
list: TStringList;
kakikomistr: TStringList;
errMsg: string;
begin
if procPost <> sender then
exit;
procPost := nil;
if Config.tstCommHeaders then
begin
//Log('--------------------');
//Log(postDat);
Log('--------------------');
Log(sender.IdHTTP.ResponseText);
Log('--------------------');
end;
FtimeValue := DateTimeToUnix(Str2DateTime(sender.GetDate));
if timeValue > FtimeValue then
timeValue := FtimeValue;
responseHTML := sender.GetString;
responseText := HTML2String(responseHTML);
Visible := true;
PageControl.Pages[2].TabVisible := true;
PageControl.ActivePageIndex := 2;
if (sender.IdHTTP.ResponseCode = 200) then
begin
if board.GetBBSType = bbsJBBSShitaraba then
responseText := euc2sjis(responseText);
list := TStringList.Create;
list.Text := responseText;
for i := 0 to list.Count -1 do
Result.Lines.Add(list.Strings);
if (2 <= list.Count) and
AnsiStartsStr('俤俼俼俷俼両', list[0]) and
AnsiStartsStr('嵞搙儘僌僀儞偟偰偹丅丅丅', list[1]) and
(writeRetryCount < 1) then
begin
list.Free;
Inc(writeRetryCount);
ticket2ch.Reset;
Result.Lines.Add('--------------------');
Result.Lines.Add('儘僌僀儞偐傜嵞帋峴拞丒丒丒');
Result.Lines.Add('--------------------');
PostArticle;
exit;
end;
errMsg := GetErrMsg;
if (errMsg = 'error') then
begin
list.Free;
ButtonWrite.Enabled := true;
exit;
end;
if ((errMsg = 'cookie') or
((2 <= list.Count) and AnsiContainsStr(list[0], '僋僢僉乕妋擣両'))) and
(cookieRetryCount < 1) then
begin
list.Free;
Inc(cookieRetryCount);
with sender.IdHTTP.CookieManager.CookieCollection do
begin
for i := 0 to Count -1 do
begin
//if (Items.CookieName = 'SPID') or (Items.CookieName = 'PON') then
if (Items.CookieName <> 'NAME') and (Items.CookieName <> 'MAIL') then
begin
//Config.tstWrtCookie := Items.Value;
//break;
Config.tstWrtCookie := Config.tstWrtCookie + Items.ClientCookie + '; ';
end;
end;
end;
Config.Modified := True;
PostArticle;
exit;
end;
if (errMsg = 'check') or
((2 <= list.Count) and AnsiContainsStr(list[1], '彂偒崬傒妋擣')) then
begin
list.Free;
SetPostCode;
exit;
end;
if not (((errMsg <> '') and ((errMsg = 'true') or (errMsg = 'false'))) or
((errMsg = '') and (list.Count > 0) and
(AnsiContainsStr(list[0], '彂偒偙傒傑偟偨') or
AnsiContainsStr(list[0], '彂偒崬傒傑偟偨'))))then
begin
list.Free;
ButtonWrite.Enabled := true;
exit;
end;
list.Free;
end
else if (sender.IdHTTP.ResponseCode = 302) then //仴偍偦傜偔奜晹斅偱偺惉岟
begin
Result.Lines.Add('彂偒崬傔偨偐傕丒丒丒');
Result.Lines.Add('--------------------');
end
else begin
Result.Lines.Add('彂崬傒偵幐攕偟偨柾條');
Result.Lines.Add('--------------------');
Result.Lines.Add(sender.IdHTTP.ResponseText);
Result.Lines.Add('--------------------');
ButtonWrite.Enabled := true;
exit;
end;
if thread <> nil then
begin
thread.LastWrote := DateTimeToUnix(Now);
thread.SaveIndexData;
//仴彂偒崬傒棜楌曐懚
if Config.wrtRecordWriting then
begin
if not FileExists(Config.BasePath + 'kakikomi.txt') then
try
FileClose(FileCreate(Config.BasePath + 'kakikomi.txt'));
except
end;
if kakikomiFile = nil then
try
kakikomiFile := TFileStream.Create(Config.BasePath + 'kakikomi.txt',
fmOpenReadWrite or fmShareDenyWrite);
except
end;
kakikomistr := TStringList.Create;
try
kakikomistr.Add('--------------------------------------------');
kakikomistr.Add('Date : ' + DateToStr(Date) + ' ' + TimeToStr(Time));
kakikomistr.Add('Subject: ' + thread.title);
kakikomistr.Add('URL : ' + MainWnd.ThreadToURL(thread, false));
kakikomistr.Add('FROM : ' + EditNameBox.Text);
kakikomistr.Add('MAIL : ' + EditMailBox.Text);
kakikomistr.Add('');
kakikomistr.AddStrings(Memo.Lines);
kakikomistr.Add('');
kakikomistr.Add('');
kakikomiFile.Seek(0, soFromEnd);
kakikomiFile.Write(PChar(kakikomistr.Text)^, length(kakikomistr.Text));
finally
kakikomistr.Free;
end;
end;
viewItem := viewList.FindViewItem(thread);
if viewItem <> nil then
viewItem.NewRequest(thread, gotCHECK, -1, True, Config.oprCheckNewWRedraw);
end;
if errMsg = 'false' then
begin
Caption := '拲堄偑弌偰偄傑偡';
exit;
end;
if Config.tstCloseAfterWriting then
Visible := False;
end;
(* 暵偠偨傛偆偵尒偣傞帪偺張棟 *)
procedure TWriteForm.FormHide(Sender: TObject);
begin
if procPost = nil then
begin
board := nil;
if assigned(thread) then
thread.Release;
thread := nil;
Result.Clear;
end;
end;
(* 儘乕僇儖儖乕儖庢摼張棟丅 *)
procedure TWriteForm.GetLocalRule;
{$IFDEF IE}
var
URL, flag: OleVariant;
begin
if gotRule <> tpsNone then
exit;
gotRule := tpsProgress;
URL := 'about:blank';
flag := $0E;
WebBrowser.Navigate2(URL, flag);
(* 偦偺偆偪WebBrowserDocumentComplete偑屇偽傟傞 *)
end;
{$ELSE}
begin
if gotRule <> tpsNone then
exit;
TextView.Clear;
RequestToGetLocalRule;
end;
{$ENDIF}
{$IFDEF IE}
(* 僇僉僐弨旛偑弌棃偨偺偱儘乕僇儖儖乕儖傪撉傒偵峴偔 *)
(* 儊儞僪僀偐傜僔乕働儞僔儍儖 *)
procedure TWriteForm.WebBrowserDocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
(* *)
if gotRule = tpsProgress then
RequestToGetLocalRule;
end;
{$ENDIF}
procedure TWriteForm.RequestToGetLocalRule;
var
URI: string;
lastModified: string;
begin
lastModified := '';
if storedRule = nil then
begin
storedRule := TLocalCopy.Create(board.GetLogDir + '/head.txt', '.idb');
storedRule.Load;
if 2 <= storedRule.Info.Count then
lastModified := storedRule.Info.Strings[1];
end;
gotRule := tpsWorking;
URI := board.GetURIBase + '/head.txt';
procGet := AsyncManager.Get(URI, OnLocalRule, ticket2ch.On2chPreConnect,
lastModified);
end;
(* 儘乕僇儖儖乕儖庢摼姰椆僴儞僪儔 *)
procedure TWriteForm.OnLocalRule(sender: TAsyncReq);
{$IFNDEF IE}
procedure WriteHTML(localRule: string);
var
ht2v: TSimpleDat2View;
begin
ht2v := TSimpleDat2View.Create(TextView);
ht2v.WriteHTML(localRule);
ht2v.Free;
end;
{$ENDIF}
var
localRule: string;
begin
if procGet = sender then
begin
case sender.IdHTTP.ResponseCode of
200: (* OK *)
begin
storedRule.Clear;
storedRule.WriteString(sender.Content);
storedRule.Info.Add('');
storedRule.Info.Add(sender.GetLastModified);
storedRule.Save;
end;
304: (* Not Modified *)
begin
end;
else
begin
storedRule.Clear;
end;
end;
localRule := storedRule.DataString;
procGet := nil;
{$IFDEF IE}
(* 婛偵桳傞敜 *)
if Assigned(WebBrowser.Document) then
begin
OleVariant(WebBrowser.Document as IHTMLDocument2).write('<html><body>'#13#10);
if Config.viewDefFontInfo.face <> '' then
begin
OleVariant(WebBrowser.Document as IHTMLDocument2)
.write('<font face="' + Config.viewDefFontInfo.face + '">');
end;
OleVariant(WebBrowser.Document as IHTMLDocument2).write(localRule);
OleVariant(WebBrowser.Document as IHTMLDocument2).write('</body></html>'#13#10);
end;
{$ELSE}
WriteHTML(localRule);
{$ENDIF}
storedRule.Free;
storedRule := nil;
gotRule := tpsDone;
end;
end;
{$IFDEF IE}
(* 儘乕僇儖儖乕儖夋柺偱偺儕儞僋僋儕僢僋帪張棟 *)
procedure TWriteForm.WebBrowserBeforeNavigate2(Sender: TObject;
const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
begin
BeforeNavigate(URL, Cancel);
end;
{$ELSE}
procedure TWriteForm.OnBrowserMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
TVMouseProc(THogeTextView(Sender), Shift, X, Y);
end;
procedure TWriteForm.OnBrowserMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Cancel: WordBool;
URL: String;
begin
case Button of
mbLeft:
begin
URL := TVMouseProc(THogeTextView(Sender), Shift, X, Y);
if 0 < length(URL) then
begin
Cancel := False;
BeforeNavigate(URL, Cancel);
end;
end;
end;
end;
{$ENDIF}
procedure TWriteForm.BeforeNavigate(const URL: String; var Cancel: WordBool);
var
URI: String;
begin
if URL = 'about:blank' then
exit;
if AnsiStartsStr('http://', URL) then
begin
Cancel := true;
MainWnd.OpenByBrowser(URL);
end
{$IFDEF IE}
else if AnsiStartsStr('about:blank', URL) then
begin
Cancel := true;
URI := board.GetURIBase + '/' + Copy(URL, 12, length(URL)-11);
MainWnd.OpenByBrowser(URI);
end;
{$ELSE}
else begin
Cancel := true;
URI := board.GetURIBase + '/' + URL;
MainWnd.OpenByBrowser(URI);
end;
{$ENDIF}
end;
procedure TWriteForm.FormDestroy(Sender: TObject);
begin
if storedRule <> nil then
begin
storedRule.Free;
storedRule := nil;
end;
{$IFDEF IE}
WebBrowser.Free;
{$ELSE}
TextView.Free;
{$ENDIF}
//仴僐僥僴儞儕僗僩曐懚
//if FileExists(Config.BasePath + 'name.dat') then
// EditNameBox.Items.SaveToFile(Config.BasePath + 'name.dat');
if kakikomiFile <> nil then
kakikomiFile.Free;
//仴傛偔傢偐傫側偄偗偳堦墳
Application.UnhookMainWindow(Hook);
end;
//仴Tips偵偁傞傑傫傑
function TWriteForm.Hook(var Message: TMessage): Boolean;
begin
case Message.Msg of
CM_APPKEYDOWN:
Result := True; // 僔儑乕僩僇僢僩傪柍岠偵偡傞
CM_APPSYSCOMMAND:
Result := True; // 傾僋僙儔儗乕僞傪柍岠偵偡傞
else
Result := False;
end;
end;
procedure TWriteForm.FormShortCut(var Msg: TWMKey; var Handled: Boolean);
begin
case Msg.CharCode of
VK_ESCAPE:
begin
if GetKeyState(VK_SHIFT) < 0 then
MainWnd.MenuWndThreadClick(Self)
else if Config.wrtEscClose then
ButtonCancelClick(Self);
end;
end;
end;
procedure TWriteForm.MemoKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
Ord('A'), Ord('a'):
begin
if ssCtrl in Shift then
Memo.SelectAll;
end;
end;
end;
end.
]