dialup.pas

DialUp,一个外国人编写的拨号的pas

  FTimer.Enabled := False;
  FTimer.Interval := 1;
  FTimer.OnTimer := Timer;
  FPossibleConnections := TStringList.Create;
  FLangStrList := TStringList.Create;
  FLangStrList.Add('Connecting to %s...');
  FLangStrList.Add('Verifying username and password...');
  FLangStrList.Add('An error occured while trying to connect to %s.');

  // Attempt to load the RASAPI32 DLL.  If the DLL loads, hRasDLL will
  //   be non-zero.  Otherwise, hRasDLL will be zero.

  hRasDLL := LoadLibrary('RASAPI32.DLL');

  // Assign function pointers for the RAS functions.

  @RasEnumConnections    := GetProcAddress(hRasDLL, 'RasEnumConnectionsA');
  @RasHangUp             := GetProcAddress(hRasDLL, 'RasHangUpA');
  @RasGetConnectStatus   := GetProcAddress(hRasDLL, 'RasGetConnectStatusA');
  @RasEnumEntries        := GetProcAddress(hRasDLL, 'RasEnumEntriesA');
  @RasGetEntryDialParams := GetProcAddress(hRasDLL, 'RasGetEntryDialParamsA');
  @RasGetErrorString     := GetProcAddress(hRasDLL, 'RasGetErrorStringA');
  @RasDial               := GetProcAddress(hRasDLL, 'RasDialA');
  @RasSetEntryDialParams := GetProcAddress(hRasDLL, 'RasSetEntryDialParamsA');

end;

destructor TDialUp.Destroy;
begin

  // If the RASAPI32 DLL was loaded, then free it.

  if RasInstalled then
    FreeLibrary(hRasDLL);

  FLangStrList.Free;
  FPossibleConnections.Free;
  FTimer.Free;
  inherited Destroy;
end;

function TDialUp.GetRasInstalled: Boolean;
// Determines if RAS has been installed by checking for DLL handle.  If RAS
//   has not been installed, hRasDLL is zero.

begin
  Result := hRasDLL <> 0;
end;

function TDialUp.GetCurrentConnection: String;
begin
  Result := GetActiveConnection;
end;

procedure TDialUp.SetCurrentConnection(Value: String);
begin
end;

procedure TDialUp.SetPossibleConnections(Value: TStringList);
begin
end;

function TDialUp.GetPossibleConnections: TStringList;
begin
  FPossibleConnections.Clear;
  GetConnections(FPossibleConnections);
  Result := FPossibleConnections;
end;

procedure TDialUp.SetLangStrList(Value: TStringList);
begin
  FLangStrList.Assign(Value);
end;

function TDialUp.GoOnline: Boolean;
var
  hRAS: ThRASConn;
  B: LongBool;
  R: Integer;
  C: array[0..100] of Char;
  DialParams: TRasDialParams;
begin
  Result := False;

  if not RasInstalled then exit;

  try
    GoOffline;
    FillChar(DialParams, SizeOf(TRasDialParams), 0);
    DialParams.dwSize := Sizeof(TRasDialParams);
    StrPCopy(DialParams.szEntryName, FConnectTo);
    B := False;
    R := RasGetEntryDialParams(nil, DialParams, B);
    if R <> 0 then begin
      Result := False;
      GoOffline;
      if Assigned(FOnStatusEvent) then FOnStatusEvent(Self,  FLangStrList[28], True);
      Exit;
    end;
    DialParams.dwSize := Sizeof(TRasDialParams);
    StrPCopy(DialParams.szUserName, FUsername);
    StrPCopy(DialParams.szPassword, FPassword);
    R := RasSetEntryDialParams(nil, DialParams, False);
    if R <> 0 then begin
      Result := False;
      GoOffline;
      if Assigned(FOnStatusEvent) then FOnStatusEvent(Self,  FLangStrList[29], True);
      Exit;
    end;
    xSelf := Self;
    AsyncStatus := False;
    hRAS := 0;
    R := RasDial(nil, nil, DialParams, 0, @RasCallback, hRAS);
    if R <> 0 then begin
      Result := False;
      RasGetErrorString(R, C, 100);
      GoOffline;
      if Assigned(FOnStatusEvent) then FOnStatusEvent(Self, C, True);
      Exit;
    end;
    Result := True;
  except
    on E: Exception do begin
      GoOffline;
      if Assigned(FOnStatusEvent) then FOnStatusEvent(Self, E.Message, True);
    end;
  end;
end;

procedure TDialUp.GetConnections(var SL: TStringList);
var
  BuffSize, Entries, R, I: Integer;
  Entry: array[1..100] of TRasEntryName;
begin

  if not RasInstalled then exit;

  SL.Clear;
  Entry[1].dwSize := SizeOf(TRasEntryName);
  BuffSize := SizeOf(TRasEntryName) * 100;
  R := RasEnumEntries(nil, nil, @Entry[1], BuffSize, Entries);
  if (R = 0) and (Entries > 0) then
    for I := 1 to Entries do SL.Add(Entry[I].szEntryName);
end;

function TDialUp.GetActiveConnection: String;
var
  BufSize, NumEntries, I, R: Integer;
  Entries: array[1..100] of TRasConn;
  Stat: TRasConnStatus;
begin
  Result := '';

  if not RasInstalled then exit;

  Entries[1].dwSize := SizeOf(TRasConn);
  BufSize := SizeOf(TRasConn)*100;
  FillChar(Stat, Sizeof(TRasConnStatus), 0);
  Stat.dwSize := Sizeof(TRasConnStatus);
  R := RasEnumConnections(@Entries[1], BufSize, NumEntries);
  if R = 0 then
    if NumEntries > 0 then
      for I := 1 to NumEntries do begin
        RasGetConnectStatus(Entries[I].HRasConn, Stat);
        if Stat.RasConnState = RASCS_Connected then
          Result := Entries[I].szEntryName+' ('+Entries[I].szDeviceName+')'
     end;
end;

procedure TDialUp.GoOffline;
var
  Entries: array[1..100] of TRasConn;
  BufSize, NumEntries, R, I, E: Integer;
begin

  if not RasInstalled then exit;

  for E := 0 to 6 do begin
    Entries[1].dwSize := SizeOf(TRasConn);
    R := RasEnumConnections(@Entries[1], BufSize, NumEntries);
    if R = 0 then begin
      if NumEntries > 0 then
        for I := 1 to NumEntries do RasHangUp(Entries[I].HRasConn);
    end;
    Application.ProcessMessages;
  end;
end;

function TDialUp.StatusString(State: TRasConnState; Error: Integer; var ES: Boolean): String;
var
  C: array[0..100] of Char;
  S: String;
begin
  S := 'Something went wrong...';
  ES := False;

  if not RasInstalled then exit;

  if Error <> 0 then begin
    RasGetErrorString(Error, C, 100);
    ES := True;
    S := C;
  end else begin
    case State of
      //connecting
      RASCS_OpenPort, RASCS_PortOpened, RASCS_ConnectDevice, RASCS_DeviceConnected,
      RASCS_AllDevicesConnected, RASCS_PrepareForCallback, RASCS_WaitForModemReset,
      RASCS_WaitForCallback, RASCS_Projected, RASCS_CallbackComplete, RASCS_LogonNetwork,
      RASCS_Interactive, RASCS_CallbackSetByCaller, RASCS_Connected: S := Format(FLangStrList[0], [FConnectTo]);
      //authenticateing
      RASCS_Authenticate, RASCS_StartAuthentication, RASCS_Authenticated: S := FLangStrList[1];
      //error
      RASCS_AuthNotify, RASCS_AuthRetry, RASCS_AuthCallback, RASCS_AuthChangePassword,
      RASCS_AuthProject, RASCS_AuthLinkSpeed, RASCS_AuthAck, RASCS_ReAuthenticate,
      RASCS_RetryAuthentication, RASCS_Disconnected, RASCS_PasswordExpired: S := Format(FLangStrList[2], [FConnectTo]);
    end;
  end;
  Result := S;
end;

procedure TDialUp.ShowAbout;
var
  S: String;
begin
  S := 'TDialUp v1.0'+#13+#13+
  'Copyright (c) 1998 Michael Haller ([e-mail])  '+#13+#13+
  'Based on the component of BEALsoft ([e-mail])'+#13+
  'and the header of Davide Moretti ([e-mail]).'+#13+#13+
  'This component is provided "as is" without any warranties.'+#13+
  'Use at your own risk!'+#13;
  MessageDlg(S, mtInformation, [mbOK], 0);
end;

end.