maindm.pas

功能强大的ER图建模工具的源代码。 可以代替ERWin了

unit MainDM;

//----------------------------------------------------------------------------------------------------------------------
//
// This file is part of fabFORCE DBDesigner4.
// Copyright (C) 2002, 2003 Michael G. Zinner, www.fabFORCE.net
//
// DBDesigner4 is free software; you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation; either version 2 of the License, or
// (at your option) any later version.
//
// DBDesigner4 is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with DBDesigner4; if not, write to the Free Software
// Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
//
//----------------------------------------------------------------------------------------------------------------------
//
// Unit MainDM.pas
// ---------------
// Version 1.6, 06.05.2003, Mike
// Description
//   Contains all global used functions to CopyDir and CopyDirRecursive
//
// Changes:
//   Version 1.6, 06.05.2003, Mike
//     added GetGlobalSettingsPath
//   Version 1.5, 18.04.2003, Mike
//     fixed bug in EncodeText4XML causing special chars to be saved invalid to XML file
//   Version 1.4, 07.04.2003, Mike
//     Responde to new -disablePersonalSettings parameter (Windows only)
//   Version 1.3, 04.04.2003, Ulli
//     fixed bug in CopyDirRecursive when using PromptBeforeOverwrite flag
//   Version 1.2, 01.04.2003, Ulli
//     added PromptBeforeOverwrite parameter to
//   Version 1.1, 25.03.2003, Mike
//     2 procedures EncodeStreamForXML, DecodeStreamFromXML added to
//     support encoding and decoding for XML from streams
//   Version 1.0, 13.03.2003, Mike
//     initial version, Mike
//
//----------------------------------------------------------------------------------------------------------------------

interface

uses
  {$IFDEF MSWINDOWS}
  Windows, Messages,
  ActiveX, ShellAPI, ShlObj, // for SHGetSpecialFolderLocation() und SHGetPathFromIDList()
  {$ENDIF}
  SysUtils, Classes, DBXpress, DB, SqlExpr, FMTBcd, Provider, DBClient,
  DBLocal, QDialogs, QComCtrls, IniFiles, QForms, Qt,
  QButtons, QControls, QMenus,
  {$IFDEF USE_IXMLDBMODELType}
  xmldom, XMLIntf, XMLDoc,
  {$ENDIF}
  QTypes, QExtCtrls, Types, Math, QStdCtrls, QGraphics,
  GlobalSysFunctions;

type
  TDMMain = class(TDataModule)  // SQLDataSet to get Schema Info.

    //Constructor of the DataModule
    procedure DataModuleCreate(Sender: TObject);
    //Destructor of the DataModule
    procedure DataModuleDestroy(Sender: TObject);


    //Initialze a form by setting the default font
    procedure InitForm(theForm: TForm; SetFloatOnTop: Boolean = False; Translate: Boolean = True);

    procedure LoadApplicationFont;

    //Get language
    procedure LoadLanguageFromIniFile;
    procedure SaveLanguageToIniFile;

    //Reads a section from a text file that is organized like an ini file
    procedure GetSectionFromTxtFile(filename, section: string; theStringList: TStringList; GetOnlyValues: Boolean = False);
    //Translate Form
    procedure TranslateForm(theForm: TForm);
    //Get Translated strings  #
    procedure GetFormResourceStrings(theForm: TForm; name: string; theStrings: TStringList);
    procedure LoadTranslatedMessages;
    function GetTranslatedMessage(OriginalMsg: string; MsgNr: integer; StrToInsert: string = ''; StrToInsert2: string = ''): string;
    procedure ResetProgramLanguage;
    function GetLanguageCode: string;
    procedure SetLanguageCode(LanguageCode: string);

    //Copies a file
    procedure CopyDiskFile(sourcefile, destinationfile: string; PromtBeforeOverwrite: Boolean = True);

    //delete all files from a directory
    procedure DelFilesFromDir(dirname, fname: string);
    // Delete Directory
    procedure DelDir(name: string);
    // Delete Directory
    procedure DelDirRecursive(name: string);
    // Copy Directory with subdirs
    procedure CopyDir(fromdir, todir: string; PromptBeforeOverwrite: Boolean = True);
    // Copy Directory with subdirs
    procedure CopyDirRecursive(fromdir, todir: string; PromptBeforeOverwrite: Boolean = True);



    //Loads a cursor from bmp files
    procedure LoadACursor(crNumber: integer; fname, fname_mask: string; XSpot, YSpot: integer);

    //Not Case Sensitive MiKe = mike
    function ReplaceText(txt, such, ers: string): string;
    //Case Sensitive MiKe <> mike
    function ReplaceString(txt, such, ers: string): string;

    //Subfunktionen
    function ReplaceText2(txt, such, ers: string): string;
    function ReplaceString2(txt, such, ers: string): string;

    //Get an ID which is unique in the application
    function GetNextGlobalID: integer;
    procedure SetGlobalID(i: integer);

    //Show the String Editor modal
    function ShowStringEditor(ATitle, APromt: string; var value: string; SelectionStart: integer = 0; LimitChars: integer = 0): Boolean;

    //Encode normal text for the use in XML files
    function EncodeText4XML(s: string): string;
    //Decode normal text which was encoded with EncodeText4XML
    function DecodeXMLText(s: string): string;


    //Saves Windowposition into INI File
    procedure SaveWinPos(win: TForm; DoSize: Boolean);
    //Recalls Windowposition from INI File
    procedure RestoreWinPos(win: TForm; DoSize: Boolean);


    //Create prozess
    procedure CreateProz(command, workingdir: string; show, wait4proz: integer);
    //Kill prozess
    procedure KillProz;

    //Start a webbrowser and browse the given webpage
    procedure BrowsePage(s: string);

    //Format text for the use in an SQL Command, text will be enclosed by '
    function FormatText4SQL(s: string): string;

    //Display the online help web pages
    procedure ShowHelp(page, name: string);

    //Get the pointer to a form with the passed name
    function GetFormByName(name: string): TForm;

    //for data import
    function GetSubStringCountInString(txt, such: string): integer;
    function FixLength(s: string; l: integer; alignLeft: boolean = True; FillChar: char = ' '): string;

    function GetColumnCountFromSepString(s, sep, delim: string): integer;
    function GetColumnFromSepString(s: string; colnr: integer; sep, delim: string): string;
    function GetColumnFromFixLengthString(s: string;
      colnr: integer; SList: TStringList): string;

    //analizes an SQL insert command
    function GetValueFromSQLInsert(FieldName, InsertStr: string): string;


    //Reverses a TList
    procedure ReverseList(ObjList: TList);

    {$IFDEF MSWINDOWS}
    function GetWindowHandle(wTitle: String): HWnd;
    procedure SetWinPos(Handle, x, y, w, h: integer);

    //This procedure is used as a workaround of a CLX bug
    procedure OnOpenSaveDlgShow(Sender: TObject);
    {$ENDIF}

    //Save Bitmap als PNG, JPG or BMP
    procedure SaveBitmap(Handle: QPixmapH; FileName: string; FileType: string; JPGQuality: integer = 75);

    function GetFileSize(fname: string): string;
    function GetFileDate(fname: string): TDateTime;

    function LoadValueFromSettingsIniFile(section, name, default: string): string;
    procedure SaveValueInSettingsIniFile(section, name, value: string);

    function RGB(r, g, b: BYTE): integer;
    function HexStringToInt(s: string): integer;


    //-----------------------------------------
    //Workaround Code because of Delphi BUG
    procedure NormalizeStayOnTopForms;
    procedure RestoreStayOnTopForms;

    procedure NormalizeStayOnTopForm(theForm: TForm);
    procedure MakeFormStayOnTop(theForm: TForm);
    function IsFormStayingOnTop(theForm: TForm): Boolean;
    //Workaround Code because of Delphi BUG END
    //-----------------------------------------

{$IFDEF LINUX}
    procedure LinuxCorrectWinPos(Sender: TObject);
{$ENDIF}

    function EncodeStreamForXML(theStream: TStream): string;
    function DecodeStreamFromXML(XMLData: string; theStream: TStream): string;

    function CheckIniFileVersion(IniFileName: string; neededVersion: integer): Boolean;

    function GetValidObjectName(name: string): string;
  private
    { Private declarations }
    GlobalIDSequ: integer;

    WinPosCorrection: Array[0..5] of TPoint;

    //-----------------------------------------
    //Workaround Code because of Delphi BUG
    StayOnTopForms: TList;
    TopMostForm: TForm;
    ApplicationIsActive: Boolean;
    //Workaround Code because of Delphi BUG END
    //-----------------------------------------

    {$IFDEF MSWINDOWS}
    ProcessInfo : TProcessInformation;
    {$ENDIF}

    LanguageCode: String;
    MessageCaptions: TStringList;
  public
    { Public declarations }
    ProgName: string;

    SettingsPath: string;

    NormalizeEditorForms: Boolean;

    LockFormDeactivateTracking: Boolean;

{$IFDEF MSWINDOWS}
    disablePersonalSettings: Boolean;
{$ENDIF}

    HTMLBrowserAppl: string;

    ApplicationFontName: string;
    ApplicationFontSize: integer;
    ApplicationFontStyle: TFontStyles;
  end;



  TCmdExecThread = class(TThread)
  private
    { Private declarations }
  protected
    FOnComplete: TNotifyEvent;
    FCommand: String;
    FReturnValue: Integer;
    //FDone is used instead of Terminated because Terminated is
    // false in the OnComplete event handler.
    FDone: Boolean;
    procedure Execute; override;
    procedure FireCompleteEvent;
  public
    constructor Create;
    property OnComplete: TNotifyEvent read FOnComplete write FOnComplete;
    property Command: String read FCommand write FCommand;
    property ReturnValue: Integer read FReturnValue;
    property Done: Boolean read FDone write FDone;
  end;

  function sendCLXEvent(receiver: QObjectH; event: QEventH): Boolean;

const
  DIGIT = ['0'..'9'];
  ALPHA_UC = ['A'..'Z'];
  ALPHA_LC = ['a'..'z'];
  ALPHANUMERIC = DIGIT + ALPHA_UC + ALPHA_LC;
  VALID_OBJECTNAME_CHARS = ALPHANUMERIC + ['_'];

var
  DMMain: TDMMain;
{$IFDEF MSWINDOWS}
  global_winname: string;

type
  PHWnd = ^HWnd;
{$ENDIF}

implementation

uses {$IFDEF LINUX}Libc, {$ENDIF}
  EditorString, StrUtils;

{$R *.xfm}

procedure TDMMain.DataModuleCreate(Sender: TObject);
var i: integer;
begin
  GlobalIDSequ:=1000;

  //Get the program name
  ProgName:=Copy(ExtractFileName(Application.ExeName), 1,
    Length(ExtractFileName(Application.ExeName))-
    Length(ExtractFileExt(Application.ExeName)));

  //Get the global Settings Path
  SettingsPath:=GetGlobalSettingsPath;

  for i:=0 to 5 do
    WinPosCorrection[i]:=Point(0, 0);


  //-----------------------------------------
  //Workaround Code because of Delphi BUG
  ApplicationIsActive:=True;
  LockFormDeactivateTracking:=False;
  StayOnTopForms:=TList.Create;
  TopMostForm:=nil;
  //Workaround Code because of Delphi BUG END
  //-----------------------------------------


  //Translation
  MessageCaptions:=TStringList.Create;

  HTMLBrowserAppl:='';

  LoadApplicationFont;

  Application.Font.Name:=ApplicationFontName;
  Application.Font.Size:=ApplicationFontSize;
  Application.Font.Style:=ApplicationFontStyle;
end;

//Destructor of the DataModule
procedure TDMMain.DataModuleDestroy(Sender: TObject);
begin
  SaveLanguageToIniFile;

  StayOnTopForms.Free;
  MessageCaptions.Free;
end;


procedure TDMMain.CopyDiskFile(sourcefile, destinationfile: string; PromtBeforeOverwrite: Boolean);
var NewFile: TFileStream;
  OldFile: TFileStream;
begin
  if(FileExists(sourcefile))then
  begin
    if(FileExists(destinationfile))and(PromtBeforeOverwrite)then
    begin
      if(MessageDlg(GetTranslatedMessage('The destination file %s does already exist. '+
        'Do you want to overwrite this file?', 22, destinationfile), mtCustom, [mbYes, mbNo], 0) = 3)then
        DeleteFile(destinationfile)
      else
        Exit;
    end;

    OldFile := TFileStream.Create(sourcefile, fmOpenRead or fmShareDenyWrite);
    try
      NewFile := TFileStream.Create(destinationfile, fmCreate{or fmShareDenyRead});

      try
        NewFile.CopyFrom(OldFile, OldFile.Size);
      finally
        FreeAndNil(NewFile);
      end;
    finally
      FreeAndNil(OldFile);
    end;
  end
  else
    MessageDlg(GetTranslatedMessage('The source file %s does not exist.', 23, sourcefile), mtError, [mbOK], 0);
end;

procedure TDMMain.LoadACursor(crNumber: integer; fname, fname_mask: string; XSpot, YSpot: integer);
var BMap, BMask: QBitMapH;
  FN : WideString;
  format: string;
begin
  //Check ist Files exist
  if(Not(FileExists(fname)))then
    raise EInOutError.Create(GetTranslatedMessage('File %s does not exist.', 24, fname));
  if(Not(FileExists(fname_mask)))then
    raise EInOutError.Create(GetTranslatedMessage('File %s does not exist.', 24, fname_mask));

  FN:=fname;
  BMap:=QBitmap_create(@FN, PChar(Format));
  FN:=fname_mask;
  BMask:=QBitmap_create(@FN, PChar(Format));
  Screen.Cursors[crNumber]:=QCursor_create(BMap, BMask, XSpot, YSpot);
  QBitmap_destroy(BMap);
  QBitmap_destroy(BMask);
end;

function TDMMain.ReplaceText(txt, such, ers: string): string;
begin
  ReplaceText:=ReplaceText2(ReplaceText2(txt, such, '