//***********************************************************
// *
// *
// *
// *
// http://aton.126.com *
// *
//***********************************************************
unit _DelphiBand;
interface
uses
SndKey32, StdCtrls, Windows, Classes, ActiveX, ShlObj, ComServ, ComObj,
controls, SysUtils, messages, Forms, Shdocvw_tlb, DelphiBandForm,mshtml;
const
DeskBand = '{00021492-0000-0000-C000-000000000046}';
VerticalBand = '{00021493-0000-0000-C000-000000000046}';
HorizontalBand = '{00021494-0000-0000-C000-000000000046}';
// ******************************************************************
Caption = 'Aton网站注册器';
BandType = VerticalBand;
ToolBand = FALSE;
CLSID_DelphiBand: TGUID = '{3F5A62E2-51F2-11D3-A075-CC7364CAE42A}';
// ******** Create your own unique identifier for each Band ********
// In Delphi-IDE : Ctrl-Shift-G
// ******************************************************************
type
TDelphiBandFactory = class(TComObjectFactory)
private
procedure AddKeys;
procedure RemoveKeys;
public
procedure UpdateRegistry(Register: Boolean); override;
end;
TDelphiBand = class(TComObject, IDeskBand, IPersistStreamInit, IObjectWithSite, IContextMenu, IInputObject)
private
MenuItems : Integer;
SavedWndProc: TWndMethod;
HasFocus: Boolean;
BandID: DWORD;
ParentWnd: HWND;
Site: IInputObjectSite;
cmdTarget: IOleCommandTarget;
BandForm: TBandform;
public
// IDeskBand methods
function GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):
HResult; stdcall;
function ShowDW(fShow: BOOL): HResult; stdcall;
function CloseDW(dwReserved: DWORD): HResult; stdcall;
function ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown;
fReserved: BOOL): HResult; stdcall;
function GetWindow(out wnd: HWnd): HResult; stdcall;
function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
// IPersistStreamInit methods
function InitNew: HResult; stdcall;
function GetClassID(out classID: TCLSID): HResult; stdcall;
function IsDirty: HResult; stdcall;
function Load(const stm: IStream): HResult; stdcall;
function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;
function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
// IObjectWithSite methods
function SetSite(const pUnkSite: IUnknown): HResult; stdcall;
function GetSite(const riid: TIID; out site: IUnknown): HResult; stdcall;
// IContextMenu methods
function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;
function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult; stdcall;
/// IInputObject methods
function UIActivateIO(fActivate: BOOL; var lpMsg: TMsg): HResult; stdcall;
function HasFocusIO: HResult; stdcall;
function TranslateAcceleratorIO(var lpMsg: TMsg): HResult; stdcall;
procedure BandWndProc(var Message: TMessage);
procedure FocusChange(bHasFocus: Boolean);
procedure UpdateBandInfo;
procedure readdocument;
procedure readdocument2;
procedure filldocument;
procedure filldocument2;
procedure readandwrite;
procedure submitinfo;
procedure load_from_file2;
end;
procedure CloseBand;
procedure NavigateFromBand(const URL: string);
///////////////////////////////////////////////
procedure fill(old:string; var new: string);
procedure Button4Click();
///////////////////////////////////////////////
var
IE: IWebbrowser2;
s:tstrings;
memo1:Tmemo;
memo2:tmemo;
username1,password1,nickname1,truename1,email1,id1,y1,m1,d1:string;
question1,answer1:string;
locationurl1:string;
implementation
uses dialogs, Registry;
//////////////////////////////////////////////////////////////////////////////////
procedure Button4Click();
begin
//
end;
procedure fill(old:string; var new: string);
var
s:array of string;
ss:string;
temp,l,r,left,right:string;
temp_str1,temp_str2,temp_str3:string;
begin
temp:=old;
while (length(temp)>3) do begin
right:=strscan(pchar(temp),'>');
//right:=copy(right,2,length(right));
left:=copy(temp,1,length(temp)-length(right));
if (((AnsiPos(AnsiUpperCase('input'),AnsiUpperCase(left))<>0) and
(AnsiPos(AnsiUpperCase('hidden'),AnsiUpperCase(left))=0)) or (AnsiPos(AnsiUpperCase('<head>'),AnsiUpperCase(left))=0))then begin
if ((AnsiPos(AnsiUpperCase('value'),AnsiUpperCase(left))<>0) and
(AnsiPos(AnsiUpperCase('提'),(left))=0) and(AnsiPos(AnsiUpperCase('重'),(left))=0)
and (AnsiPos(AnsiUpperCase('确'),(left))=0) and(AnsiPos(AnsiUpperCase('登'),(left))=0)
and (AnsiPos(AnsiUpperCase('完'),(left))=0) and(AnsiPos(AnsiUpperCase('入'),(left))=0)
and (AnsiPos(AnsiUpperCase('取'),(left))=0) and(AnsiPos(AnsiUpperCase('注'),(left))=0))
then begin
temp_str2:=AnsiUpperCase(left);
temp_str1:=strRscan(pchar(temp_str2),'V');
left:=copy(left,1,length(left)-length(temp_str1));
end;
if (AnsiPos(AnsiUpperCase('Username'),AnsiUpperCase(left))<>0) then left:=left+' value="'+username1+'"'
else if (AnsiPos(AnsiUpperCase('uid'),AnsiUpperCase(left))<>0) then left:=left+' value="'+username1+'"'
else if (AnsiPos(AnsiUpperCase('name=u'),AnsiUpperCase(left))<>0) then left:=left+' value="'+username1+'"'
else if (AnsiPos(AnsiUpperCase('name=user'),AnsiUpperCase(left))<>0) then left:=left+' value="'+username1+'"'
// else if (AnsiPos(AnsiUpperCase('name'),AnsiUpperCase(left))<>0) then left:=left+' value='+username1
else if (AnsiPos(AnsiUpperCase('cn'),AnsiUpperCase(left))<>0) then left:=left+' value="'+username1+'"'
else if (AnsiPos(AnsiUpperCase('password'),AnsiUpperCase(left))<>0) then left:=left+' value="'+password1+'"'
else if (AnsiPos(AnsiUpperCase('psw'),AnsiUpperCase(left))<>0) then left:=left+' value="'+password1+'"'
else if (AnsiPos(AnsiUpperCase('Nickname'),AnsiUpperCase(left))<>0) then left:=left+' value="'+nickname1+'"'
else if (AnsiPos(AnsiUpperCase('Nick'),AnsiUpperCase(left))<>0) then left:=left+' value="'+nickname1+'"'
else if (AnsiPos(AnsiUpperCase('truename'),AnsiUpperCase(left))<>0) then left:=left+' value="'+truename1+'"'
else if (AnsiPos(AnsiUpperCase('que'),AnsiUpperCase(left))<>0) then left:=left+' value="'+question1+'"'
else if (AnsiPos(AnsiUpperCase('answer'),AnsiUpperCase(left))<>0) then left:=left+' value="'+answer1+'"'
else if (AnsiPos(AnsiUpperCase('year'),AnsiUpperCase(left))<>0) then left:=left+' value="'+y1+'"'
else if (AnsiPos(AnsiUpperCase('month'),AnsiUpperCase(left))<>0) then left:=left+' value="'+m1+'"'
else if (AnsiPos(AnsiUpperCase('day'),AnsiUpperCase(left))<>0) then left:=left+' value="'+d1+'"'
else if (AnsiPos(AnsiUpperCase('<head'),AnsiUpperCase(left))<>0) then left:=left+' > <BASE HREF="'+locationurl1+'" '
else if (AnsiPos(AnsiUpperCase('mail'),AnsiUpperCase(left))<>0) then left:=left+' value="'+email1+'"';
l:=l+left+'>';
temp:=copy(right,2,length(right));
end
else begin
l:=l+left+'>';
temp:=copy(right,2,length(right));
end;
end;
new:=l+temp;
end;
//////////////////////////////////////////////////////////////////////////////////
procedure TDelphiBand.UpdateBandInfo;
(*
Band objects can send commands to their container.
Two commands are supported:
DBID_BANDINFOCHANGED
The band's information has changed. The container will call the band
object's GetBandInfo method to request the updated information.
DBID_MAXIMIZEBAND
The container will maximize the band.
*)
var
vain, vaOut: OleVariant;
PtrGuid: PGUID;
begin
vaIn := Variant(BandID);
New(PtrGUID);
PtrGUID^ := IDESKBAND;
cmdTarget.Exec(PtrGUID, DBID_BANDINFOCHANGED, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
Dispose(PtrGUID);
end;
procedure CloseBand;
var
x, y, z: Olevariant;
begin
x := GuidToString(CLSID_DelphiBand);
Y := FALSE;
Z := 0;
IE.ShowBrowserBar(X, Y, Z);
end;
procedure NavigateFromBand(const URL: string);
var
_url: OleVariant;
X: OleVariant;
begin
_Url := Url;
X := 0;
IE.Navigate(Url, X, X, X, X);
end;
function TDelphiBand.GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):
HResult;
// Retrieves the information for the band object.
begin
BandId := dwBandID;
if (pdbi.dwMask or DBIM_MINSIZE) <> 0
then begin
pdbi.ptMinSize.y := BandForm.Width;
pdbi.ptMinSize.x := 0;
end;
if (pdbi.dwMask or DBIM_MAXSIZE) <> 0
then begin
pdbi.ptMaxSize.x := -1;
pdbi.ptMaxSize.y := -1;
end;
if (pdbi.dwMask or DBIM_INTEGRAL) <> 0
then begin
pdbi.ptIntegral.x := 1;
pdbi.ptIntegral.y := 1;
end;
if (pdbi.dwMask or DBIM_ACTUAL) <> 0
then begin
pdbi.ptActual.x := Bandform.Height;
pdbi.ptActual.y := bandform.Width;
end;
if (pdbi.dwMask or DBIM_MODEFLAGS) <> 0 then
begin
pdbi.dwModeFlags := DBIMF_VARIABLEHEIGHT;
end;
if (pdbi.dwMask or DBIM_BKCOLOR) <> 0 then
begin
pdbi.dwMask := pdbi.dwMask and (not DBIM_BKCOLOR);
end;
if (Pdbi.dwMask and DBIM_TITLE) = DBIM_TITLE
then begin
FillChar(pdbi.wszTitle, SizeOf(Caption) + 1, ' ');
StringToWideChar(Caption, @pdbi.wszTitle, Length(Caption) + 1);
end;
Result := NOERROR;
end;
function TDelphiBand.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult;
begin
//Add Menuitems here in reverse order:
InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdfirst + 3, '使用新的填充方法');
InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst + 2, '关于……');
InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst + 1, '提交注册信息');
InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdfirst, '填充注册信息');
// Return number of items added:
MenuItems := 4;
Result := MenuItems;
end;
function TDelphiBand.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
begin
if (HiWord(Integer(lpici.lpVerb)) <> 0) or (LoWord(lpici.lpVerb) > MenuItems-1) then
begin
Result := E_FAIL;
Exit;
end;
case LoWord(lpici.lpVerb) of
// Add menu commands:
// 0: UpdateBandInfo;
0: readandwrite;
//1: NavigateFromBand('http://www.euromind.com/iedelphi');
1: submitinfo;
2: Showmessage('Aton网站注册器（0.91版）');
3: Showmessage(getcurrentdir);
end;
Result := NO_ERROR;
end;
procedure TDelphiBand.BandWndProc(var Message: TMessage);
begin
// WM_PARENTNOTIFY is called when the band receive focus
// so information is passed on to OnFocusChangeIS ->
if (Message.Msg = WM_PARENTNOTIFY) then
begin
HasFocus:=true;
FocusChange(True);
end;
SavedWndProc(Message);
end;
function TDelphiBand.GetWindow(out wnd: HWnd): HResult;
begin
// Create Bandform as child window and pass handle
if not Assigned(BandForm) then
BandForm := TBandForm.CreateParented(ParentWnd);
Wnd := Bandform.Handle;
// Important to notify IInputObjectSite each time focus is on the band
// object, so TranslateAcceleratorOI can be called. ->
SavedWndProc := Bandform.WindowProc;
Bandform.WindowProc := BandWndProc;
Result := S_OK;
end;
procedure TDelphiBand.FocusChange(bHasFocus: Boolean);
begin
// Informs the browser that the focus has changed.
if (Site <> nil) then Site.OnFocusChangeIS(Self, bHasFocus);
end;
function TDelphiBand.TranslateAcceleratorIO(var lpMsg: TMsg): HResult;
// Passes keyboard accelerators to the object.
// So VK_BACK, VK_LEFT, VK_RIGHT etc. are available for
// components on the band.
begin
if (lpMsg.WParam <> VK_TAB) then begin
TranslateMessage(lpMSg);
DispatchMessage(lpMsg);
Result := S_OK;
end
else Result := S_FALSE;
end;
function TDelphiBand.HasFocusIO: HResult;
// Determines if one of the object's windows has the keyboard focus.
begin
Result:=Integer(not HasFocus);
end;
function TDelphiBand.UIActivateIO(fActivate: BOOL;
var lpMsg: TMsg): HResult;
// Activates or deactivates the object.
begin
// No need to notify when focus leaved the band object, since
// TranslateAcceleratorIO only is called from the band.
Hasfocus:=fActivate;
if HasFocus then Bandform.SetFocus;
Result := S_OK;
end;
function TDelphiBand.SetSite(const pUnkSite: IUnknown): HResult;
// When the user selects an Explorer Bar, the container calls
// the corresponding band object's SetSite method. The punkSite
// parameter will be set to the site's IUnknown pointer.
begin
//If the pointer passed to SetSite is set to Nil, the band is being removed.
//SetSite can return S_OK. ->
if Assigned(pUnkSite) then begin
// Store the pointer to this interface for use later. ->
Site := pUnkSite as IInputObjectSite;
//Call GetWindow to obtain the parent window's handle,
//and save it for future use. ->
(pUnkSite as IOleWindow).GetWindow(ParentWnd);
// Need IOleCommandTarget if you want to send commands to the container
// (see UpdateBandInfo) ->
cmdTarget := pUnkSite as IOleCommandTarget;
// Get a connection to IE's browser-window ->
(CmdTarget as IServiceProvider).QueryService(IWebbrowserApp, IWebbrowser2, IE);
end;
Result := S_OK;
end;
function TDelphiBand.GetSite(const riid: TIID; out site: IUnknown): HResult;
// Retrieves the last site set with SetSite.
begin
if Assigned(Site) then Result := Site.QueryInterface(riid, site)
else Result := E_FAIL;
end;
function TDelphiBand.ShowDW(fShow: BOOL): HResult;
begin
Result := S_OK;
end;
function TDelphiBand.GetClassID(out classID: TCLSID): HResult;
begin
classID := CLSID_DelphiBand;
Result := S_OK;
end;
function TDelphiBand.CloseDW(dwReserved: DWORD): HResult;
begin
if BandForm <> nil then BandForm.Destroy;
Result := S_OK;
end;
function TDelphiBand.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
begin
Result := NOERROR;
end;
function TDelphiBand.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
begin
Result := E_NOTIMPL;
end;
function TDelphiBand.ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown;
fReserved: BOOL): HResult;
begin
Result := E_NOTIMPL;
end;
function TDelphiBand.IsDirty: HResult;
begin
Result := S_FALSE;
end;
function TDelphiBand.Load(const stm: IStream): HResult;
begin
Result := S_OK;
end;
function TDelphiBand.Save(const stm: IStream; fClearDirty: BOOL): HResult;
begin
Result := S_OK;
end;
function TDelphiBand.GetSizeMax(out cbSize: Largeint): HResult;
begin
Result := E_NOTIMPL;
end;
function TDelphiBand.InitNew: HResult;
begin
Result := E_NOTIMPL;
end;
procedure TDelphiBandFactory.UpdateRegistry(Register: Boolean);
begin
inherited UpdateRegistry(Register);
if Register then AddKeys else RemoveKeys;
end;
procedure TDelphiBandFactory.AddKeys;
var S: string;
begin
S := GUIDToString(CLSID_DelphiBand);
with TRegistry.Create do
try
// http://support.microsoft.com/support/kb/articles/Q247/7/05.ASP ->
if BandType <> DeskBand then
begin
DeleteKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Discardable\PostSetup\Component Categories\' + VerticalBand + '\Enum');
DeleteKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Discardable\PostSetup\Component Categories\' + HorizontalBand + '\Enum');
end;
RootKey := HKEY_CLASSES_ROOT;
if OpenKey('CLSID\' + S, True) then
begin
WriteString('', '&Aton网站注册器');
CloseKey;
end;
if OpenKey('CLSID\' + S + '\InProcServer32', True) then
begin
WriteString('ThreadingModel', 'Apartment');
CloseKey;
end;
if OpenKey('CLSID\' + S + '\Implemented Categories\' + BandType, True)
then CloseKey;
if Toolband then begin
RootKey := HKEY_LOCAL_MACHINE;
if OpenKey('SOFTWARE\Microsoft\Internet Explorer\Toolbar', True) then
begin
WriteString(S, '');
CloseKey;
end;
end;
finally
Free;
end;
end;
procedure TDelphiBandFactory.RemoveKeys;
var S: string;
begin
S := GUIDToString(CLSID_DelphiBand);
with TRegistry.Create do
try
RootKey := HKEY_CLASSES_ROOT;
// http://support.microsoft.com/support/kb/articles/Q214/8/42.ASP ->
if BandType = DeskBand then
DeleteKey('Component Categories\' + DeskBand + '\Enum');
DeleteKey('CLSID\' + S + '\Implemented Categories\' + BandType);
DeleteKey('CLSID\' + S + '\InProcServer32');
DeleteKey('CLSID\' + S);
Closekey;
if ToolBand then begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('Software\Microsoft\Internet Explorer\Toolbar', FALSE);
DeleteValue(s);
CloseKey;
end;
finally
Free;
end;
end;
procedure TDelphiBand.filldocument;
var
m:tmemorystream;
s2:string;
begin
load_from_file2;
Button4Click();
fill(memo1.text,s2);
memo1.text:=s2;
M := TMemoryStream.Create;
memo1.Lines.SaveToStream(M);
M.seek(0, 0);
if not Assigned(ie.document) then begin
NavigateFromBand('about:blank');
while ie.readystate <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages;
end;
(ie.Document as IPersistStreamInit).Load(TStreamadapter.Create(M));
end;
procedure TDelphiBand.readdocument;
var
IpStream: IPersistStreamInit;
A: TMemoryStream;
begin
locationurl1:=ie.LocationURL;
memo1 := Tmemo.CreateParented(ParentWnd);
with ie do begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(document) then begin
A := TMemoryStream.Create;
try
IpStream := document as IPersistStreamInit;
if not Assigned(IpStream) then showmessage('Err') else
if Succeeded(IpStream.save(TStreamadapter.Create(A), TRUE))
then begin
A.Seek(0, 0);
memo1.lines.LoadFromStream(A);
end;
except
end;
A.Free;
end;
end;
// showmessage(memo1.text);
end;
procedure tdelphiband.load_from_file2;
var
sss:string;
i,j,k:integer;
q:array [1..20] of string;
t,t0,t1,t2,t3,t4:string;
MySysPath : PCHAR ;
begin
GetMem(MySysPath,255);
GetSystemDirectory(MySysPath,255);
memo2 := Tmemo.CreateParented(ParentWnd);
//memo2.Lines.LoadFromFile(ExtractFilePath(Paramstr(0))+'info.web');
if fileexists(MySysPath+'\info.web') then
memo2.Lines.LoadFromFile(MySysPath+'\info.web')
else showmessage('你还没有填写你的个人信息！');
t:=memo2.Text;
memo2.Destroy;
t0:=t;
for i:=1 to 20 do begin
t1:=strscan(pchar(t0),' ');
t2:=copy(t0,1,length(t0)-length(t1));
t3:=trim(t2);
t0:=trim(t1);
q[i]:=t3;
end;
username1:=q[1];
password1:=q[2];
nickname1:=q[3];
truename1:=q[4];
id1:=q[5];
y1:=q[6];
m1:=q[7];
d1:=q[8];
email1:=q[9];
question1:='你认为aton网站注册器怎么样？';
answer1:='非常棒！！！';
//username1,password1,nickname1,truename1,email1,id1,y1,m1,d1:string;
//question1,answer1:string;
//showmessage(q[1]+'and'+q[2]);
end;
procedure TDelphiBand.readandwrite;
begin
readdocument;
//if length(memo1.text)>100 then begin
filldocument;
//end;
end;
procedure TDelphiBand.submitinfo;
begin
IHTMLWindow2(IHTMLDocument2(ie.Document).ParentWindow).focus;
Sendkeys('~',true);
end;
procedure TDelphiBand.filldocument2;
begin
//
end;
procedure TDelphiBand.readdocument2;
begin
//
end;
initialization
TDelphiBandFactory.Create(ComServer, TDelphiBand, CLSID_DelphiBand, '', Caption, ciMultiInstance);
end.