Windows7での時刻設定（解決）

解決

take 2015-08-20 19:53:07 No: 47551

以前Windows7での時刻設定を行えなえず
アクセストークンも効かないことで相談しましたが
解決の目処が立ちましたので報告だけ

SNTPサーバーを真似れば時計を合わせられると考えましたが
Windows7では、自分のIPアドレスへは読みにいかないようでダメでした

アドバイスを頂いたサービスアプリケーションを別途作成し
ソケット通信を使用してメインソフトから時計データを受け取り
時計に反映させることに成功しました。

サービスの起動や停止もメインソフトから制御出来そうな所まで来ています。

サービスをインストールをインストーラーから行うのがちょっと敷居が高そうなのですが
最悪でもそこは手動で行っても良いので
およそ理想の動作をするようになりました。

ありがとうございました。

サービスアプリケーションクラス(TService)の
基礎的な使い方があまりネット上になさそうなので
今後のために記載しておきます。

type
  TTimeAjust = class(TService)
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
    procedure ServiceCreate(Sender: TObject);
    procedure ServiceDestroy(Sender: TObject);
    procedure ServiceExecute(Sender: TService);
  private
    { Private 宣言 }

    function ProcessMessages() : Boolean;
  public
    function GetServiceController: TServiceController; override;
    { Public 宣言 }
  end;

var
TimeAjust: TTimeAjust;

implementation

{$R *.DFM}

procedure TTimeAjust.ServiceCreate(Sender: TObject);
begin
end;

procedure TTimeAjust.ServiceDestroy(Sender: TObject);
begin
end;

procedure TTimeAjust.ServiceStart(Sender: TService; var Started: Boolean);
begin
Started := True;
end;

procedure TTimeAjust.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
Stopped := True;
end;

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
TimeAjustJJY.Controller(CtrlCode);
end;

function TTimeAjust.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;

function TTimeAjust.ProcessMessages() : Boolean;
var
  Msg : TMsg;
  OldStatus : TCurrentStatus;
  ActionOK : Boolean;
begin
  result := PeekMessage(Msg,0,0,0,PM_REMOVE);
  if (not result) then exit;
  with Msg do
    if (hwnd = 0) and (message = CM_SERVICE_CONTROL_CODE) then begin
      OldStatus := Status;
      try
        result := False;
        ActionOK := True;
        case wParam of
          SERVICE_CONTROL_STOP : begin
            ActionOK := DoStop;
            result := ActionOK;
          end;

          SERVICE_CONTROL_PAUSE : begin
            ActionOK := DoPause;
            result := False;
          end;

          SERVICE_CONTROL_CONTINUE : begin
            ActionOK := DoContinue;
            result := False;
          end;

          SERVICE_CONTROL_SHUTDOWN : begin
            DoShutDown;
            result := True;
          end;

          SERVICE_CONTROL_INTERROGATE : begin
            DoInterrogate;
            result := False;
          end;

        end;
        if (not ActionOK) then Status := OldStatus;
      finally
      end;
    end;

end;

procedure TTimeAjust.ServiceExecute(Sender: TService);
begin

  while (not Terminated) do begin
    if (ProcessMessages) then begin
      break;
    end;
  end
end;

take 2015-08-20 19:53:54 No: 47552

解決済みとします