From b11b2a89e2dea097e22c74f2448d2b773866be9d Mon Sep 17 00:00:00 2001 From: Proof Date: Tue, 26 Jul 2016 18:34:13 +0400 Subject: [PATCH] utils delphi utils --- ExportData.pas | 91 +++++++++++ MarshalOblect.pas | 65 ++++++++ OraUpLoadData.pas | 293 ++++++++++++++++++++++++++++++++++ OracleUtils.pas | 160 +++++++++++++++++++ uFoxProDBF.pas | 345 +++++++++++++++++++++++++++++++++++++++ uMap.pas | 399 ++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 1353 insertions(+) create mode 100644 ExportData.pas create mode 100644 MarshalOblect.pas create mode 100644 OraUpLoadData.pas create mode 100644 OracleUtils.pas create mode 100644 uFoxProDBF.pas create mode 100644 uMap.pas diff --git a/ExportData.pas b/ExportData.pas new file mode 100644 index 0000000..b3a9c2e --- /dev/null +++ b/ExportData.pas @@ -0,0 +1,91 @@ +unit ExportData; + +interface + +uses Oracle, OracleData, Classes, ComObj; + +type TExport = class + private + fFullPath: string; + fDataSet: TOracleDataSet; + + function CorrectData: Boolean; + public + constructor Create(aFullPath: String; aOraSataSet: TOracleDataSet); overload; + + property FullPath: string read fFullPath write fFullPath; + property OraDataSet: TOracleDataSet read fDataSet write fDataSet; + + function ExportOraToCSV: Boolean; + function ExportOraToXLS(aShowTitle: Boolean): Boolean; + //function ExportOraToXLSX: Boolean; +end; + +implementation + +constructor TExport.Create(aFullPath: String; aOraSataSet: TOracleDataSet); +begin + fFullPath := aFullPath; + fDataSet := aOraSataSet; +end; + +function TExport.CorrectData: Boolean; +begin + // +end; + +function TExport.ExportOraToCSV: Boolean; +var + f: TextFile; + i: Integer; +begin + try + AssignFile(f, fFullPath); + //Rewrite(f); + Reset(f); + fDataSet.First; + while not fDataSet.Eof do + begin + for i := 0 to fDataSet.FieldCount - 1 do + begin + Writeln(f, fDataSet.Fields.FieldByNumber(i).Value + ';'); + end; + fDataSet.Next; + end; + finally + CloseFile(f); + end; + +end; + +function TExport.ExportOraToXLS(aShowTitle: Boolean): Boolean; +var + x: Variant; + i, j: Integer; +begin + x := CreateOleObject('Excel.Application'); + x.Workbooks.Add; + + j := 1; + if aShowTitle then + begin + for i := 0 to fDataSet.FieldCount - 1 do + x.ActiveWorkBook.WorkSheets[1].Cells[j, i + 1] := + fDataSet.Fields.Fields[i].DisplayLabel; + j := 2; + end; + + while not fDataSet.Eof do + begin + for i := 0 to fDataSet.FieldCount - 1 do + begin + x.ActiveWorkBook.WorkSheets[1].Cells[j, i + 1] := + fDataSet.Fields.Fields[i].AsString; + end; + fDataSet.Next; + inc(j); + end; + x.Visible := true; +end; + +end. diff --git a/MarshalOblect.pas b/MarshalOblect.pas new file mode 100644 index 0000000..66868b0 --- /dev/null +++ b/MarshalOblect.pas @@ -0,0 +1,65 @@ +unit MarshalOblect; + +interface + +uses + SysUtils, DBXJSON, DBXJSONReflect; + +function DeepCopy(aValue: TObject): TObject; +function ObjectTOJson(aObject: TObject): String; //TJSONValue; +function JsonTOObject(aJson: TJSONValue): TObject; + +implementation + +function DeepCopy(aValue: TObject): TObject; +var + MarshalObj: TJSONMarshal; + UnMarshalObj: TJSONUnMarshal; + JSONValue: TJSONValue; +begin + Result:= nil; + MarshalObj := TJSONMarshal.Create; + UnMarshalObj := TJSONUnMarshal.Create; + try + JSONValue := MarshalObj.Marshal(aValue); + try + if Assigned(JSONValue) then + Result:= UnMarshalObj.Unmarshal(JSONValue); + finally + JSONValue.Free; + end; + finally + MarshalObj.Free; + UnMarshalObj.Free; + end; +end; + +function ObjectTOJson(aObject: TObject): String; //TJSONValue; +var + MarshalObj: TJSONMarshal; +begin + Assert(Assigned(aObject), '{9682C06D-717C-4E75-9F81-38D2B64DCB96}'); + + MarshalObj := TJSONMarshal.Create; + try + Result := MarshalObj.Marshal(aObject).ToString; + finally + FreeAndNil(MarshalObj); + end; +end; + +function JsonTOObject(aJson: TJSONValue): TObject; +var + UnMarshalObj: TJSONUnMarshal; +begin + Assert(Assigned(aJson), '{A3A45FE9-7E30-4662-A279-00A917FD099F}'); + + UnMarshalObj := TJSONUnMarshal.Create; + try + Result:= UnMarshalObj.Unmarshal(aJson); + finally + FreeAndNil(UnMarshalObj); + end; +end; + +end. diff --git a/OraUpLoadData.pas b/OraUpLoadData.pas new file mode 100644 index 0000000..9e7e7f9 --- /dev/null +++ b/OraUpLoadData.pas @@ -0,0 +1,293 @@ +unit OraUpLoadData; + +interface + +uses + Windows, SysUtils, Classes + , DB + , Oracle + , OracleData + , Contnrs + ; + +{$IFDEF Unicode} +type TData = array of array of AnsiString; +{$ELSE} +type TData = array of array of String; +{$ENDIF} + +type TUpLoadField = class + private + fid: Integer; + fUserColumnNum: Integer; + fName: string; + fColumnType: TDirectPathColumnType; + fUsed: Boolean; + public + property Id: Integer read fId; + property UserColumnNum: Integer read fUserColumnNum write fUserColumnNum; + property Name: string read fName write fName; + property ColumnType: TDirectPathColumnType read fColumnType write fColumnType; + property Used: Boolean read fUsed write fUsed; +end; + +type TOracleUpLoadData = class + private + fOraSession: TOracleSession; + fTableName: string; + fOraDirectPath: TOracleDirectPathLoader; + fBufferSize: Cardinal; + fUsedColumnNum: Boolean; + fArrIdColumns: array of array of Integer; + fUploadFields: tObjectList; + private + procedure SetId; + procedure SetFields; + procedure ODPPrepare; + procedure SetBufferSize(aValue: Cardinal); + function SetArrIdColumns: Boolean; + function GetUpLoadFields(index: Integer): TUpLoadField; + public + property TableName: string read fTableName; + property BufferSize: cardinal read fBufferSize write SetBufferSize; + property Fields[index: integer]: TUpLoadField read GetUpLoadFields; default; + property UsedColumnNum: Boolean read fUsedColumnNum write fUsedColumnNum; //Будут использоваться TUpLoadField.UserColumnNum + public + function FieldsCount: Integer; + function FieldsUsedCount: Integer; + function UpLoad(aArData: TData): Boolean; overload; virtual; //[row, column] + function UpLoad(aDS: TDataSet): Boolean; overload; virtual; + public + constructor Create(aOraSession: TOracleSession; aTableName: string); overload; + constructor Create(aDataBase, aUserName, aPassword, aTableName: string); overload; + procedure AfterConstruction; override; + procedure BeforeDestruction; override; +end; + +implementation + +procedure TOracleUpLoadData.SetId; +var + i: Integer; +begin + for i := 0 to fUploadFields.Count - 1 do + Fields[i].fid := i; +end; + +procedure TOracleUpLoadData.SetFields; +var + i: Integer; + t: TUpLoadField; + c: TDirectPathColumn; +begin + Assert(fOraSession.Connected, '{131ACFCE-C464-4477-A0A0-2770BFFC36CE}'); + Assert(fTableName > '', '{97C996FF-6C58-4E3B-A46F-81561AB4BD69}'); + + for i := 0 to fOraDirectPath.Columns.Count - 1 do + begin + c := fOraDirectPath.Columns[i]; + t := TUpLoadField.Create; + + t.Name := c.Name; + t.fColumnType := c.DataType; + t.Used := true; + t.UserColumnNum := -1; + fUploadFields.Add(t); + end; +end; + +procedure TOracleUpLoadData.ODPPrepare; +begin + fOraDirectPath.BufferSize := fBufferSize; + fOraDirectPath.Prepare; +end; + +procedure TOracleUpLoadData.SetBufferSize(aValue: Cardinal); +begin + fBufferSize := aValue; + ODPPrepare; +end; + +function TOracleUpLoadData.SetArrIdColumns: Boolean; +var + i, c: Integer; +begin + Result := True; + fArrIdColumns := nil; + c := 0; + for i := 0 to fUploadFields.Count - 1 do + begin + if (Fields[i].Used) then + begin + SetLength(fArrIdColumns, c + 1); + SetLength(fArrIdColumns[c], 2); + fArrIdColumns[c, 0] := Fields[i].Id; + fArrIdColumns[c, 1] := Fields[i].UserColumnNum; + if ((UsedColumnNum) and (fArrIdColumns[c, 1] < 0)) then + Result := False; + Inc(c); + end; + end; +end; + +function TOracleUpLoadData.GetUpLoadFields(index: Integer): TUpLoadField; +begin + Result := TUpLoadField(fUploadFields[index]); +end; + +function TOracleUpLoadData.FieldsCount: Integer; +begin + Result := fUploadFields.Count; +end; + +function TOracleUpLoadData.FieldsUsedCount: Integer; +var + i: Integer; +begin + Result := 0; + for i := 0 to fUploadFields.Count - 1 do + if Fields[i].Used then + Inc(Result); +end; + +function TOracleUpLoadData.UpLoad(aArData: TData): Boolean; +var + i, c, vRows: Integer; + + procedure NotUseColumn; + var + j, k: Integer; + begin + for j := 0 to High(aArData[i]) do + begin + k := fArrIdColumns[j, 0]; + if (aArData[i, j] > '') then + fOraDirectPath.Columns[k].SetData(vRows, @aArData[i, j][1], Length(aArData[i, j])); + end; + end; + + procedure UseColumn; + var + j, k, n: Integer; + begin + for j := 0 to High(fArrIdColumns) do + begin + k := fArrIdColumns[j, 0]; + n := fArrIdColumns[j, 1]; + //OutputDebugString(PChar(Format('UseColumn:%d, %d, %d, %s', [vRows, j, Length(aArData[i, n]), aArData[i, n]]))); + if (aArData[i, n] > '') then + fOraDirectPath.Columns[k].SetData( + vRows + , @aArData[i, n][1] + , Length(aArData[i, n]){*SizeOf(Char)} + ); + end; + end; + +begin + Result := False; + if (High(aArData) < 0) then + Exit; + + if (not SetArrIdColumns) then + Exit; + + c := High(aArData[0]) + 1; + if (c <> FieldsUsedCount) then + Exit; + + vRows := 0; + for i := 0 to High(aArData) do + begin + if (fOraDirectPath.MaxRows = vRows) then + begin + fOraDirectPath.Load(vRows); + vRows := 0; + end; + if (UsedColumnNum) then + UseColumn + else + NotUseColumn; + Inc(vRows); + end; + fOraDirectPath.Load(vRows); + + fOraDirectPath.Finish; + Result := True; +end; + +function TOracleUpLoadData.UpLoad(aDS: TDataSet): Boolean; +var + r, i, c: Integer; + d: TData; +begin + Assert(aDS.Active, '{CF062155-3411-455E-9A38-C59ED4B8B556}'); + + r := 0; + c := aDS.FieldCount; + + aDS.First; + while (not aDS.Eof) do + begin + SetLength(d, r + 1); + for i := 0 to c - 1 do + begin + SetLength(d[r], c); + d[r, i] := aDS.Fields[i].AsString; + end; + Inc(r); + aDS.Next; + end; + Result := UpLoad(d); + d := nil; +end; + +constructor TOracleUpLoadData.Create(aOraSession: TOracleSession; aTableName: string); +begin + fOraSession := TOracleSession.Create(nil); + aOraSession.Share(fOraSession); + fTableName := aTableName; +end; + +constructor TOracleUpLoadData.Create(aDataBase, aUserName, aPassword, aTableName: string); +begin + fOraSession := TOracleSession.Create(nil); + + fOraSession.LogonDatabase := aDataBase; + fOraSession.LogonUsername := aUserName; + fOraSession.LogonPassword := aPassword; + + fTableName := aTableName; +end; + +procedure TOracleUpLoadData.AfterConstruction; +begin + inherited; + + fOraSession.Connected := True; + fUsedColumnNum := False; + + fBufferSize := 512 * 1024; + + fUploadFields := TObjectList.Create; + + fOraDirectPath := TOracleDirectPathLoader.Create(nil); + + fOraDirectPath.Session := fOraSession; + fOraDirectPath.TableName := fTableName; + fOraDirectPath.GetDefaultColumns(True); + ODPPrepare; + + SetFields; + SetId; +end; + +procedure TOracleUpLoadData.BeforeDestruction; +begin + FreeAndNil(fUploadFields); + FreeAndNil(fOraDirectPath); + + Inherited; +end; + +end. diff --git a/OracleUtils.pas b/OracleUtils.pas new file mode 100644 index 0000000..7714dee --- /dev/null +++ b/OracleUtils.pas @@ -0,0 +1,160 @@ +unit OracleUtils; + +interface + +uses +{$ifdef debug} + Windows, +{$endif} + SysUtils, Classes, OracleData, Oracle, ComCtrls, DB + ; + +// Заполняем список из OracleQuery +procedure FillListFromQuery(aList: TStrings; aQuery: TOracleQuery; + const aIdField: string = 'ID'; const aCaptionField: string = 'NAME'); + +procedure FillListFromDataSet(aList: TStrings; aDS: TOracleDataSet; + const aIdField: string = 'ID'; const aCaptionField: string = 'NAME'); +//Получение ID из списка +function GetIdFromList(const aList: TStrings; const aPosition: Integer): Integer; + +//Заполнение ListView из OracleDataSet +procedure FillListViewFromOraDataSet(aListView: TListView; + aOraDataSet: TOracleDataSet); + +//Обновить OracleDataSet +procedure UpdateOraDataSet(aOraDS: TOracleDataSet); + +//Обновить OracleDataSet сохранив указатель на строку +function UpdateOraDataSetSaveMark(aOraDS: TOracleDataSet): Boolean; + +implementation + +procedure FillListFromQuery(aList: TStrings; aQuery: TOracleQuery; + const aIdField: string = 'ID'; const aCaptionField: string = 'NAME'); +var + vIdField, vCaptionField: Integer; +begin + Assert(Assigned(aList), '{FEFDEDDA-E9B9-4093-BB2E-E91F7ADB660F}'); + Assert(Assigned(aQuery), '{2B5305A3-F914-45E6-A14B-F4B68EB46902}'); + Assert(Assigned(aQuery.Session), '{FCE87B95-BC03-48C5-97A0-394753390716}'); + Assert(aQuery.Session.Connected, '{F74063D7-324E-4467-8E64-C88E1AD81BE7}'); + + aQuery.Execute; + + vIdField := aQuery.FieldIndex(aIdField); + vCaptionField := aQuery.FieldIndex(aCaptionField); + Assert(vIdField >= 0, '{E7FA8B79-951E-440C-9A8F-E231597CE310}'); + Assert(vCaptionField >= 0, '{38BBC5CA-FB87-461D-94DE-6AF7F6185593}'); + + aList.Clear; + + aQuery.First; + while not aQuery.Eof do + begin + aList.AddObject(aQuery.FieldAsString(vCaptionField), + tObject(aQuery.FieldAsInteger(vIdField))); + aQuery.Next; + end; +end; + +procedure FillListFromDataSet(aList: TStrings; aDS: TOracleDataSet; + const aIdField: string = 'ID'; const aCaptionField: string = 'NAME'); +var + vIdField, vCaptionField: Integer; +begin + Assert(Assigned(aList), '{789ABCD9-476D-4FF4-B1E4-B5AAD847AD3E}'); + Assert(Assigned(aDS), '{66F48CDB-4E30-458B-99F8-5BD14417FE27}'); + Assert(Assigned(aDS.Session), '{D7687D2F-9B9D-48F4-907B-3A698E48511F}'); + Assert(aDS.Session.Connected, '{316EB358-1118-45C6-ACBA-F3F4B131D610}'); + + aDS.Close; + aDS.Open; + + aDS.First; + while (not aDS.Eof) do + begin + aList.AddObject(aDS.FieldByName(aCaptionField).AsString, + tObject(aDS.FieldByName(aIdField).AsInteger)); + aDS.Next; + end; + +end; + +function GetIdFromList(const aList: TStrings; const aPosition: Integer): Integer; +begin + Assert(Assigned(aList), '{6F33ED90-1CE1-48B7-AEDA-E44BA1FE26A5}'); + Assert(aPosition >= 0, '{0F2E0211-9636-4B9C-BBD9-99188A9B39DE}'); + + Result := Integer(aList.Objects[aPosition]); +end; + +procedure FillListViewFromOraDataSet(aListView: TListView; + aOraDataSet: TOracleDataSet); +var + vItem: TListItem; + i: Integer; +begin + Assert(Assigned(aListView), '{8A257790-D8C3-4135-8F4C-33AF0C1173EC}'); + Assert(Assigned(aOraDataSet), '{6D762514-055F-43B2-AEC5-741555257F85}'); + Assert(aOraDataSet.Active, '{EB5A1185-5600-4F43-A7BE-D970BCBD6F03}'); + + aListView.Clear; + aListView.Columns.Clear; + + aListView.Items.BeginUpdate; + try + //Заполнить имена столбцов + for i := 0 to aOraDataSet.FieldCount - 1 do + begin + with aListView.Columns.Add do + begin + Caption := aOraDataSet.Fields[i].DisplayLabel; + Width := aOraDataSet.Fields[i].DisplayWidth; + end; + end; + + //Заполняем данными + aOraDataSet.First; + while not aOraDataSet.Eof do + begin + vItem := aListView.Items.Add; +{$ifdef debug} + OutputDebugString(PChar(IntToStr(vItem.Index))); + OutputDebugString(PChar(aOraDataSet.Fields[0].AsString)); +{$endif} + vItem.Caption := aOraDataSet.Fields[0].AsString; + + for i := 1 to aOraDataSet.FieldCount - 1 do + vItem.SubItems.Add(aOraDataSet.Fields[i].AsString); + + aOraDataSet.Next; + end; + + finally + aListView.Items.EndUpdate; + end; +end; + +procedure UpdateOraDataSet(aOraDS: TOracleDataSet); +begin + aOraDS.Close; + aOraDS.Open; +end; + +function UpdateOraDataSetSaveMark(aOraDS: TOracleDataSet): Boolean; +var + vBM: TBookmark; +begin + try + vBM := aOraDS.GetBookmark; + UpdateOraDataSet(aOraDS); + if (aOraDS.RecordCount > 0) then + aOraDS.GotoBookmark(vBM); + Result := True; + Except + Result := False; + end; +end; + +end. diff --git a/uFoxProDBF.pas b/uFoxProDBF.pas new file mode 100644 index 0000000..281f830 --- /dev/null +++ b/uFoxProDBF.pas @@ -0,0 +1,345 @@ +unit uFoxProDBF; + +interface + +uses + Classes, SysUtils, ADODB, DB + ; + +const + cNonError: Integer = 0; + cBadArgument: Integer = 1; + cNonConnection: Integer = 2; + cUnknown: Integer = 10; + +type TVFP = class + private + fFullFilePath: String; + fConnected: Boolean; + fFieldsList: TStrings; + + ADODBFConnection: TADOConnection; + qADODBF: TADOQuery; + + //Получить список полей в таблице + procedure GetFieldList; + //Поиск по имени поля + function SearchField(aFieldName: String): Boolean; + //Подключаемся к DBF файлу + function DBFConnection(const aFullPath: String): Boolean; + //Получить имя файла + function GetFileName: String; + function GetFileNameNoExt: string; + function GetFileNameNo: string; + //Получаем написание типа для FoXPro + function GetDBFType(aType: TFieldType; aSize: Integer): String; + function CorrectName(aName: string): string; + public + tADODBF: TADOTable; + queryADODBF: TADOQuery; + property FullFilePath: String read fFullFilePath write fFullFilePath; + property FileName: String read GetFileName; + property FileNameNoExt: String read GetFileNameNoExt; + property FileNameNo: String read GetFileNameNo; + property Connected: Boolean read fConnected write fConnected; + property FieldsList: TStrings read fFieldsList; + + procedure Connect(aFullFilePath: String); + procedure Disconnect; + //Пока работа происходит только с типами: строкой, целым типом и датой + function AddFileld(aFieldName: String; aType: TFieldType; aSize: Integer): Integer; + function RemoveField(aFieldName: String): Integer; + function RemoveUniqueKey(aKeyName: String): Integer; + function CreateUniqKey(aFieldName: string): Integer; + function FillUniqValue(aFieldName: string): Integer; + function UpdateField(aFieldKey: string; aKeyValue: integer; aUpdateField, aUpdateValue: string): integer; + procedure Commit; + + constructor Create(); + destructor Destroy; +end; + +implementation + +procedure TVFP.Commit; +begin + ADODBFConnection.Close; + ADODBFConnection.Open; + //tADODBF.Active := True; + GetFieldList; +end; + +function TVFP.GetFileNameNoExt: string; +begin + Result := '[' + StringReplace(ExtractFileName(fFullFilePath), ExtractFileExt(fFullFilePath), '', []) + ']'; +end; + +function TVFP.GetFileNameNo: string; +begin + Result := StringReplace(ExtractFileName(fFullFilePath), ExtractFileExt(fFullFilePath), '', []); +end; + +function TVFP.CorrectName(aName: string): string; +const + scInvalidChars = '-!@#$%^&()=+[]{}'; +var + i: Integer; +begin + Result := aName; + + for I := 1 to length(scInvalidChars) do + Result := StringReplace(Result, scInvalidChars[i], '_', [rfReplaceAll, rfIgnoreCase]); +end; + +function TVFP.GetDBFType(aType: TFieldType; aSize: Integer): String; +var + s: String; +begin + case (Integer(aType)) of + Integer(ftString): s := 'C(' + IntToStr(aSize) + ')'; + Integer(ftSmallint), Integer(ftInteger), Integer(ftWord), Integer(ftFloat): s := 'N(' + IntToStr(aSize) + ')'; + Integer(ftDate), Integer(ftDateTime): s:= 'D' + else + s := 'C(10)'; // Значение по умолчанию, для не описанных типов + end; + Result := s; +end; + +function TVFP.GetFileName: String; +begin + Result := ExtractFileName(fFullFilePath); +end; + +procedure TVFP.GetFieldList; +var + i: Integer; +begin + Assert(Assigned(fFieldsList), '{64E3ED23-7DC7-4CD4-9F2A-1C0DABC83B6C}'); + //Assert(tADODBF.Active, '{3E5F6377-40C6-432E-83C0-23BBCD13635C}'); + + fFieldsList.Clear; + qADODBF.SQL.Text := 'select * from ' + FileNameNoExt + ' where 1 = 2'; + qADODBF.Open; + for i := 0 to qADODBF.FieldCount - 1 do + fFieldsList.Add(qADODBF.Fields[i].DisplayName); +end; + +function TVFP.SearchField(aFieldName: String): Boolean; +begin + Assert(Assigned(fFieldsList), '{F7B80790-D1BB-4F9A-9A47-95C533D40A9B}'); + + Result := False; + + if (fFieldsList.Count = 0) then Exit; + if (fFieldsList.IndexOf(aFieldName) = -1) then Exit; + + Result := True; +end; + +function TVFP.DBFConnection(const aFullPath: String): Boolean; +Var + cs: String; +begin + //Нужно добавить проверку наличия драйвера + //DELETED=False - указавывает, что с запися помеченными на удаление, работаем как с обычными + cs := Format( + 'Provider=VFPOLEDB.1;Data Source=%s;DELETED=False' + , [aFullPath] + ) ; + + Result := False; +// if (ADODBFConnection.Connected) then + ADODBFConnection.Close; + ADODBFConnection.ConnectionString := cs; + tADODBF.TableName := FileNameNoExt; + try + ADODBFConnection.Open; + //tADODBF.Open; + except + fFullFilePath := ''; + Exit; + end; + Result := True;//tADODBF.Active; +end; + +constructor TVFP.Create; +begin + Inherited; + fFullFilePath := ''; + fConnected := False; + fFieldsList := TStringList.Create; + ADODBFConnection := TADOConnection.Create(nil); + ADODBFConnection.Mode := cmShareExclusive; + qADODBF := TADOQuery.Create(nil); + queryADODBF := TADOQuery.Create(nil); + tADODBF := TADOTable.Create(nil); + tADODBF.LockType := ltBatchOptimistic; + qADODBF.Connection := ADODBFConnection; + queryADODBF.Connection := ADODBFConnection; + tADODBF.Connection := ADODBFConnection; +end; + +destructor TVFP.Destroy; +begin + fFieldsList.Free; + ADODBFConnection.Free; + qADODBF.Free; + tADODBF.Free; + queryADODBF.Free; + + inherited; +end; + +procedure TVFP.Connect(aFullFilePath: String); +begin + if (not FileExists(aFullFilePath)) then Exit; + + fFullFilePath := aFullFilePath; + if (not DBFConnection(aFullFilePath)) then Exit; + + GetFieldList; + fConnected := True; +end; + +procedure TVFP.Disconnect; +begin + ADODBFConnection.Close; + fFullFilePath := ''; + fConnected := False; + fFieldsList.Clear; +end; + +function TVFP.AddFileld(aFieldName: String; aType: TFieldType; aSize: Integer): Integer; +begin + Assert(ADODBFConnection.Connected, '{F7F75ACF-AA1C-432F-914B-981597F7F6F5}'); + + //Плохие условия + if (not fConnected) then + begin + Result := cNonConnection; + Exit; + end; + if (aFieldName = '') then + begin + Result := cBadArgument; + Exit; + end; + + //Поле уже добавлено + if (SearchField(aFieldName)) then + begin + Result := cNonError; + Exit; + end; + + qADODBF.SQL.Text := 'alter table ' + FileNameNoExt + + ' ADD ' + aFieldName + ' ' + GetDBFType(aType, aSize); + try + qADODBF.ExecSQL; + except + Result := cUnknown; + end; + Result := cNonError; +end; + +function TVFP.RemoveField(aFieldName: String): Integer; +begin + Assert(ADODBFConnection.Connected, '{2B019729-D2A5-4A0A-9130-33C14ECF91DF}'); + + //Плохие условия + if (not fConnected) then + begin + Result := cNonConnection; + Exit; + end; + if (not SearchField(aFieldName)) then + begin + Result := cBadArgument; + Exit; + end; + + qADODBF.SQL.Text := 'alter table ' + FileNameNoExt + + ' DROP COLUMN ' + aFieldName; + try + qADODBF.ExecSQL; + //Commit; + except + Result := cUnknown; + end; + Result := cNonError; +end; + +function TVFP.RemoveUniqueKey(aKeyName: String): Integer; +begin + Assert(ADODBFConnection.Connected, '{0EB06581-C83C-4EDF-8AB3-3E362A78D8E4}'); + + //Плохие условия + if (not fConnected) then + begin + Result := cNonConnection; + Exit; + end; + + qADODBF.SQL.Text := 'alter table ' + FileNameNoExt + + ' DROP UNIQUE TAG ' + aKeyName; + try + qADODBF.ExecSQL; + except + Result := cUnknown; + end; + Result := cNonError; +end; + +function TVFP.FillUniqValue(aFieldName: string): Integer; +begin + //Пока работает только с числовым типом + if (not SearchField(aFieldName)) then + begin + Result := cBadArgument; + Exit; + end; + + qADODBF.SQL.Text := 'update ' + FileNameNoExt + ' set ' + aFieldName + ' = recno()'; + try + qADODBF.ExecSQL; + except + Result := cUnknown; + Exit; + end; + Result := cNonError; +end; + +function TVFP.CreateUniqKey(aFieldName: string): Integer; +begin + //Пока работает только с числовым типом + if (not SearchField(aFieldName)) then + begin + Result := cBadArgument; + Exit; + end; + + try + qADODBF.SQL.Text := 'ALTER TABLE ' + FileNameNoExt + ' ADD unique ' + aFieldName; + qADODBF.ExecSQL; + Except + Result := cUnknown; + Exit; + end; + Result := cNonError; +end; + +function TVFP.UpdateField(aFieldKey: string; aKeyValue: integer; aUpdateField, aUpdateValue: string): integer; +begin + qADODBF.SQL.Text := 'update ' + FileNameNoExt + + ' set ' + aUpdateField + ' = ' + aUpdateValue + + ' where ' + aFieldKey + ' = ' + IntToStr(aKeyValue); + try + qADODBF.ExecSQL; + except + Result := cUnknown; + Exit; + end; + Result := cNonError; +end; + +end. diff --git a/uMap.pas b/uMap.pas new file mode 100644 index 0000000..5443a8c --- /dev/null +++ b/uMap.pas @@ -0,0 +1,399 @@ +unit uMap; + +interface + +uses + Classes, SHDocVw, DB, SysUtils, Registry; + +const + cId: String = 'id'; + cName: String = 'name'; + cCount: String = 'cnt'; + cLon: String = 'lon'; + cLat: String = 'lat'; + cPart: String = 'part'; + cSide: String = 'side'; + +type TGeo = class(TObject) + private + fLon: Double; + fLat: Double; + public + property Lon: Double read fLon write fLon; + property Lat: Double read fLat write fLat; + public + function getString: String; +end; + +type TDataCoord = class(TObject) + private + fId: Integer; + fName: String; + fCount: Integer; + fGeo: array of array of TGeo; + public + property Id: Integer read fId write fId; + property Name: String read fName write fName; + property Count: Integer read fCount write fCount; + public + procedure setGeo(const aSide: Integer; const aLat, aLon: Double); + function getString: String; +end; + +type TMap = class(TObject) + private + fSrcHtmlFile: String; + fSrcName: String; + fHtmlName: String; + fDataSet: TDataSet; + fBrowser: TWebBrowser; + fDataCoord: array of TDataCoord; + fVersion: Integer; + private + function isAllParam: Boolean; + function setHtmlName(const aName: String): String; + function coordJSobjectGet: String; + function createHTML: Boolean; + procedure setRegistry; + procedure RemoveOldHTML; + public + property Actived: Boolean read isAllParam; + public + constructor Create(aHtmlName: String; aDataSet: TDataSet; + aBrowser: TWebBrowser; aVersion: Integer); + destructor Destroy; override; + function ShowData: Boolean; + function GetCode: TStringList; +end; + +implementation + +uses CustomerService; + +{ TMap } + +function DeleteFiles(const FileMask: string): Boolean; +var + SearchRec: TSearchRec; +begin + Result := FindFirst(ExpandFileName(FileMask), faAnyFile, SearchRec) = 0; + try + if Result then + repeat + if (SearchRec.Name[1] <> '.') and + (SearchRec.Attr and faVolumeID <> faVolumeID) and + (SearchRec.Attr and faDirectory <> faDirectory) then + begin + Result := DeleteFile(ExtractFilePath(FileMask) + SearchRec.Name); + if not Result then Break; + end; + until FindNext(SearchRec) <> 0; + finally + FindClose(SearchRec); + end; +end; + +constructor TMap.Create(aHtmlName: String; aDataSet: TDataSet; + aBrowser: TWebBrowser; aVersion: Integer); +begin + Assert(aHtmlName > '', '{F1BB4F1E-BB4B-47B3-9C49-D9D1CDE63CAD}'); + Assert(Assigned(aDataSet), '{01BF71C9-8B39-4854-B631-35315EFFB8AE}'); + Assert(Assigned(aBrowser), '{01BF71C9-8B39-4854-B631-35315EFFB8AE}'); + + fSrcHtmlFile := '04DDBE6B-66C7-4CB1-988E-44847B0C4DCD.h'; + + fVersion := aVersion; + fHtmlName := setHtmlName(aHtmlName); + fDataSet := aDataSet; + fBrowser := aBrowser; + setRegistry; + FormatSettings.DecimalSeparator := '.'; +end; + +function TMap.createHTML: Boolean; +var + p, fn, s: String; + sl: TStrings; +begin + Result := False; + + p := ExtractFilePath(ParamStr(0)); + fn := p + fSrcHtmlFile; + if (not FileExists(fn)) then + Exit; + + sl := TStringList.Create; + try + sl.LoadFromFile(p + fSrcHtmlFile); + sl.Text := StringReplace(sl.Text, '%%CoordData%%', coordJSobjectGet, [rfReplaceAll, rfIgnoreCase]); + sl.SaveToFile(p + fHtmlName, TEncoding.UTF8); + finally + FreeAndNil(sl); + end; + + Result := True; +end; + +destructor TMap.Destroy; +var + f: String; +begin + { + f := ExtractFilePath(ParamStr(0)) + fHtmlName; + if (FileExists(f)) then + DeleteFile(f); + } + inherited; +end; + +function TMap.GetCode: TStringList; +var + lst: TStringList; + tbl, row: OleVariant; + i, j, r, c: Integer; + s: String; +begin + lst := TStringList.Create; + + tbl := fBrowser.OleObject.Document.GetElementById('export_table'); + r := tbl.rows.length; + //2 - что бы не брать строку итого + for i := 0 to r - 2 do + begin + row := tbl.rows.item(i).getElementsByTagName('TH'); + if (row.length = 0) then + row := tbl.rows.item(i).getElementsByTagName('TD'); + c := row.length; + + s := ''; + for j := 0 to c - 1 do + s := s + '~' + row.Item(j).innerText; + s := Copy(s, 2); + lst.Add(s); + end; + + Result := lst; +end; + +function TMap.coordJSobjectGet: String; +var + f_id, f_name, f_cnt, f_lon, f_lat, f_part, f_side: TField; + id, part, side: Integer; + cd: TDataCoord; + i, k: Integer; +begin + Result := ''; + + f_id := fDataSet.FindField(cId); + f_name := fDataSet.FindField(cName); + f_cnt := fDataSet.FindField(cCount); + f_lon := fDataSet.FindField(cLon); + f_lat := fDataSet.FindField(cLat); + f_part := fDataSet.FindField(cPart); + f_side := fDataSet.FindField(cSide); + + id := -1000000; + part := -1000000; + side := -1000000; + + if (fDataSet.Active = False) then + fDataSet.Open; + + fDataSet.DisableControls; + try + fDataSet.First; + while not fDataSet.Eof do + begin + if ((id <> f_id.AsInteger) or (part <> f_part.AsInteger)) then + begin + id := f_id.AsInteger; + part := f_part.AsInteger; + + cd := TDataCoord.Create; + cd.Id := id; + cd.Name := f_name.AsString; + cd.Count := f_cnt.AsInteger; + + k := Length(fDataCoord); + SetLength(fDataCoord, k + 1); + fDataCoord[k] := cd; + end; + cd.setGeo(f_side.AsInteger, f_lat.AsFloat, f_lon.AsFloat); + + fDataSet.Next; + end; + finally + fDataSet.EnableControls; + end; + + Result := ''; + for i := Low(fDataCoord) to High(fDataCoord) do + Result := Result + fDataCoord[i].getString + ',' + #13; + + Result := 'var coord = [' + Result + '];'; +end; + +function TMap.isAllParam: Boolean; +var + f: String; + + function isAssigned(const aFieldName: String): Boolean; + begin + Result := Assigned(fDataSet.FieldByName(aFieldName)); + end; +begin + Result := False; + + f := ExtractFilePath(ParamStr(0)) + fSrcHtmlFile; + if (not FileExists(f)) then + Exit; + + if (not fDataSet.Active) then + fDataSet.Open; + + if (not isAssigned(cId)) then + Exit; + if (not isAssigned(cName)) then + Exit; + if (not isAssigned(cCount)) then + Exit; + if (not isAssigned(cLat)) then + Exit; + if (not isAssigned(cLon)) then + Exit; + if (not isAssigned(cPart)) then + Exit; + if (not isAssigned(cSide)) then + Exit; + + Result := True; +end; + +procedure TMap.RemoveOldHTML; +var + m: String; +begin + m := ExtractFilePath(Paramstr(0)) + fSrcName + '*.html'; + DeleteFiles(m); +end; + +function TMap.setHtmlName(const aName: String): String; +const + cExt: String = '.html'; +var + fn: String; +begin + fSrcName := aName; + fn := aName + '_' + IntToStr(fVersion); + Result := ChangeFileExt(fn, cExt); +end; + +procedure TMap.setRegistry; +var + r: TRegistry; + key: String; + fn: String; +begin + //HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\MAIN\FeatureControl\FEATURE_BROWSER_EMULATION + //HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_BROWSER_EMULATION + + //key := '\SOFTWARE\Microsoft\Internet Explorer\MAIN\FeatureControl\FEATURE_BROWSER_EMULATION\'; + key := '\Software\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_BROWSER_EMULATION\'; + fn := ExtractFileName(ParamStr(0)); + + r := TRegistry.Create; + try + //r.RootKey := $80000002; //HKEY_LOCAL_MACHINE; + r.RootKey := $80000001; //HKEY_CURRENT_USER; + if (r.KeyExists(key + fn)) then + Exit; + + r.OpenKey(key, true); + r.WriteInteger(fn, 10001); + finally + FreeAndNil(r); + end; +end; + +function TMap.ShowData: Boolean; +var + p: String; +begin + Result := False; + + p := ExtractFilePath(ParamStr(0)) + fHtmlName; + + if (not FileExists(p)) then + begin + RemoveOldHTML; + + if (not Actived) then + Exit; + + if (not createHTML) then + Exit; + end; + + fBrowser.Navigate(p); + + Result := True; +end; + +{ TCoord } + +function TGeo.getString: String; +begin + Result := '[' + FloatToStr(fLat) + ',' + FloatToStr(fLon) + ']'; +end; + +{ TDataCoord } + +function TDataCoord.getString: String; +var + s, z: String; + i, j: Integer; +begin + Result := ''; + z := ''; + + + Result := 'id:' + IntToStr(fId) + ','; + Result := Result + 'name:''' + fName + ''','; + Result := Result + 'count:' + IntToStr(fCount) + ','; + + //Собираем координаты + for i := Low(fGeo) to High(fGeo) do + begin + s := ''; + for j := Low(fGeo[i]) to High(fGeo[i]) do + begin + s := s + fGeo[i][j].getString + ','; + end; + z := z + '[' + s + '],'; + end; + Result := Result + 'geo:[' + z + '],'; + + Result := Result + 'state:0'; + + Result := '{' + Result + '}'; +end; + +procedure TDataCoord.setGeo(const aSide: Integer; const aLat, aLon: Double); +var + c, d: Integer; + g: TGeo; +begin + g := TGeo.Create; + g.Lat := aLat; + g.Lon := aLon; + + SetLength(fGeo, aSide); + + d := aSide - 1; + c := Length(fGeo[d]); + SetLength(fGeo[d], c + 1); + + fGeo[d][c] := g; +end; + +end.