main.pas.svn-base

TFormDesigner allows you move and resize any control on your form. You need not prepare your form to

        Add('Name       '#9+ObjectVar(redDFM.Lines[0]));
        Add('Type       '#9+ObjectType(redDFM.Lines[0]));
        Add('Components '#9+IntToStr(CompCount)+#13#10);
        Add('BINARY DFM');
        Add('Bytes      '#9+IntToStr(BinSize)+#13#10);
        Add('TEXT DFM');
        Add('Bytes      '#9+IntToStr(Length(redDFM.Lines.Text)));
        Add('Lines      '#9+IntToStr(redDFM.Lines.Count)+#13#10);
        Add('PAS FILE');
        Add('Bytes      '#9+IntToStr(Length(redPAS.Lines.Text)));
        Add('Lines      '#9+IntToStr(redPAS.Lines.Count));
      finally
        EndUpdate;
      end;
    end;
  finally
    Screen.Cursor:=crDefault;
  end;
end;

procedure TfrmMain.ClearForm;
begin
  with FormPanel do
  begin
    DestroyComponents;
    Parent:=nil;
  end;
  redDFM.Lines.Clear;
  redPAS.Lines.Clear;
  with redInfo.Lines do
  begin
    BeginUpdate;
    Clear;
    try
      Add('FILE');
      Add('Location   '#9+SourceFile);
      Add('Forms       0');
    finally
      EndUpdate;
    end;
  end;
  pgcMain.ActivePage:=tshInfo;
end;

procedure TfrmMain.OpenFile(FileName: string);
var
  HM: HModule;
  MI: TMenuItem;
  i: Integer;
begin
  Screen.Cursor:=crHourGlass;
  try
    SetCurrentDir(ExtractFilePath(FileName));
    HM:=LoadLibrary(PChar(FileName));
    try
      ClearList;
      if HM<>0 then
      begin
        with lsbForms,Items do
        begin
          BeginUpdate;
          try
            EnumResourceNames(HM,RT_RCDATA,@EnumFunc,Integer(Items));
          finally
            EndUpdate;
          end;
        end;
        Caption:=FileName+' - '+Application.Title;
        SourceFile:=FileName;
        with lsbForms,Items do
          if Count>0 then
          begin
            ItemIndex:=0;
            GetForm;
          end
          else ClearForm;
        with mniFileReopen do
        begin
          MI:=nil;
          for i:=0 to Pred(Count) do
            if AnsiUpperCase(Items[i].Hint)=AnsiUpperCase(SourceFile) then
            begin
              MI:=Items[i];
              Remove(MI);
              Insert(0,MI);
            end;
          if not Assigned(MI) then
          begin
            while Count>9 do Remove(Items[Pred(Count)]);
            MI:=TMenuItem.Create(Self);
            with MI do
            begin
              Hint:=SourceFile;
              OnClick:=mniFileReopenClick;
              mniFileReopen.Insert(0,MI);
            end;
          end;
          Visible:=Count>0;
          for i:=0 to Pred(Count) do
            with Items[i] do
              if Visible then Caption:=Format('&%d   %s',[i,Hint]);
        end;
      end
      else ShowError;
    finally
      FreeLibrary(HM);
    end;
    EnableActions;
  finally
    Screen.Cursor:=crDefault;
  end;
end;

procedure TfrmMain.mniHelpAboutClick(Sender: TObject);
begin
  with TfrmAbout.Create(Application) do
  try
    ShowModal;
  finally
    Free;
  end;
end;

procedure TfrmMain.mniFileReopenClick(Sender: TObject);
begin
  OpenFile((Sender as TMenuItem).Hint);
end;

procedure TfrmMain.SaveForm(Index: Integer; FileName: string; var MR: TModalResult);
var
  BIN,TXT,PAS: TMemoryStream;
  S: string;
  C: Char;
begin
  // creating streams
  BIN:=TMemoryStream.Create;
  TXT:=TMemoryStream.Create;
  PAS:=TMemoryStream.Create;
  try
    // retreiving the form information
    GetFormStreams(Index,BIN,TXT,PAS);
    if FileExists(FileName) and (MR<>mrAll) then MR:=MessageDlg('File "'+FileName+'" already exists.'#13'Overwrite?',mtConfirmation,[mbYes,mbNo,mbCancel,mbAll],0);
    if MR in [mrYes,mrAll] then
    begin
      with TFileStream.Create(FileName,fmCreate) do
      try
        if mniOptionsTextDFM.Checked then CopyFrom(TXT,TXT.Size)
        else CopyFrom(BIN,BIN.Size);
      finally
        Free;
      end;
      if mniOptionsSavePas.Checked then
      begin
        S:=ChangeFileExt(FileName,'.pas');
        if FileExists(S) and (MR<>mrAll) then MR:=MessageDlg('File "'+S+'" already exists.'#13'Overwrite?',mtConfirmation,[mbYes,mbNo,mbCancel,mbAll],0);
        if MR in [mrYes,mrAll] then
          with TFileStream.Create(S,fmCreate) do
          try
            S:=ExtractFileName(FileName);
            S:='unit '+Copy(S,1,Length(S)-Length(ExtractFileExt(S)))+';'#13#10;
            Write(S[1],Length(S));
            repeat
              PAS.Read(C,SizeOf(C));
            until C=#10;
            CopyFrom(PAS,PAS.Size-PAS.Position);
          finally
            Free;
          end;
      end;
    end;
  finally
    // destroying the streams
    BIN.Free;
    TXT.Free;
    PAS.Free;
  end;
end;

procedure TfrmMain.mniCheckClick(Sender: TObject);
begin
  with (Sender as TMenuItem) do Checked:=not Checked;
end;

procedure TfrmMain.mniFileSaveClick(Sender: TObject);
const
  MR: TModalResult = mrYes;
begin
  with svdMain do
    if Execute then
      with lsbForms do
        if ItemIndex>-1 then SaveForm(ItemIndex,FileName,MR);
end;

function BrowseProc(Handle: HWND; Msg: UINT; L,Data: LPARAM): Integer; stdcall;
begin
  Result:=0;
  if Msg=BFFM_INITIALIZED then
    SendMessage(Handle,BFFM_SETSELECTION,1,Data);
end;

procedure TfrmMain.mniFileSaveAllClick(Sender: TObject);
const
  MR: TModalResult = mrYes;
var
  i: Integer;
  BI: TBrowseInfo;
  Result: PItemIDList;
  Temp: array[0..MAX_PATH] of Char;
  Dir: string;

  procedure DisposePIDL(ID: PItemIDList);
  var
    Malloc: IMalloc;
  begin
    if Assigned(ID) and (Integer(ID)<>-1) then
    try
      OLECheck(SHGetMalloc(Malloc));
      Malloc.Free(ID);
    except
    end;
  end;

begin
  FillChar(BI,SizeOf(BI),0);
  with BI do
  begin
    hwndOwner:=Handle;
    lpszTitle:='Specify target folder for DFM and PAS files';
    ulFlags:=BIF_RETURNONLYFSDIRS or BIF_RETURNFSANCESTORS;
    lpfn:=@BrowseProc;
    lParam:=Integer(PChar(SaveAllDir));
    Result:=SHBrowseForFolder(BI);
    if Assigned(Result) then
    begin
      SHGetPathFromIDList(Result,Temp);
      SaveAllDir:=Temp;
      DisposePIDL(Result);
      Dir:=SaveAllDir;
      if Dir[Length(Dir)]<>'\' then Dir:=Dir+'\';
      with lsbForms,Items do
        for i:=0 to Pred(Count) do
        begin
          SaveForm(i,Dir+Items[i]+'Unit.dfm',MR);
          if MR=mrCancel then Exit;
        end;
    end;
  end;
end;

function TfrmMain.ActiveEditor: TRichEdit;
begin
  if (pgcMain.ActivePage.PageIndex>0) then
  try
    Result:=pgcMain.ActivePage.Controls[0] as TRichEdit;
  except
    Result:=nil;
  end
  else Result:=nil;
end;

procedure TfrmMain.EnableActions;
var
  FormsOK,TextOK,SelectOK,FindOK: Boolean;
  RE: TRichEdit;
begin
  RE:=ActiveEditor;
  FormsOK:=lsbForms.ItemIndex>-1;
  TextOK:=FormsOK and Assigned(RE) and (RE.Lines.Count>0);
  SelectOK:=TextOK and Assigned(RE) and (RE.SelLength>0);
  FindOK:=TextOK and (fidMain.FindText<>'');
  mniFileSave.Enabled:=FormsOK;
  tbtFileSave.Enabled:=FormsOK;
  mniFileSaveAll.Enabled:=FormsOK;
  tbtFileSaveAll.Enabled:=FormsOK;
  mniEditCopy.Enabled:=SelectOK;
  tbtEditCopy.Enabled:=SelectOK;
  mniEditSelectAll.Enabled:=TextOK;
  tbtEditSelectAll.Enabled:=TextOK;
  mniSearchFind.Enabled:=TextOK;
  tbtSearchFind.Enabled:=TextOK;
  mniSearchFindNext.Enabled:=FindOK;
  tbtSearchFindNext.Enabled:=FindOK;
end;

procedure TfrmMain.mniSearchFindClick(Sender: TObject);
begin
  with fidMain do
    if Execute then;
end;

procedure TfrmMain.pgcMainChange(Sender: TObject);
begin
  EnableActions;
end;

procedure TfrmMain.fidMainFind(Sender: TObject);
begin
  fidMain.CloseDialog;
  EnableActions;
  FindText;
end;

procedure TfrmMain.FindText;
var
  RE: TRichEdit;
  Start,Find: Integer;
  S,T: string;
begin
  RE:=ActiveEditor;
  if Assigned(RE) then
    with RE,Lines do
    begin
      RE.SetFocus;
      S:=AnsiUpperCase(fidMain.FindText);
      Start:=Succ(SelStart)+SelLength;
      T:=AnsiUpperCase(Copy(Text,Start,Length(Text)));
      Find:=Pos(S,T);
      if Find<>0 then
      begin
        SelStart:=Start+Find-2;
        SelLength:=Length(S);
      end
      else MessageDlg('Cannot find "'+fidMain.FindText+'"',mtInformation,[mbOK],0);
    end;
end;

procedure TfrmMain.mniSearchFindNextClick(Sender: TObject);
begin
  FindText;
end;

procedure TfrmMain.redSelectionChange(Sender: TObject);
begin
  EnableActions;
end;

procedure TfrmMain.mniEditSelectAllClick(Sender: TObject);
var
  RE: TRichEdit;
begin
  RE:=ActiveEditor;
  if Assigned(RE) then RE.SelectAll;
end;

procedure TfrmMain.mniEditCopyClick(Sender: TObject);
var
  RE: TRichEdit;
begin
  RE:=ActiveEditor;
  if Assigned(RE) then RE.CopyToClipboard;
end;

end.