PC Toledo

Código: Selecionar todos

/*
 * $Id: testdll.prg 11201 2009-06-03 10:26:40Z vszakats $
 */

/*
 * Harbour Project source code:
 *    DLL call demonstration.
 *
 * Copyright 2008 Viktor Szakats (harbour.01 syenar.hu)
 * www - http://www.harbour-project.org
 *
 */

#define MB_OK                       0x00000000
#define MB_OKCANCEL                 0x00000001
#define MB_ABORTRETRYIGNORE         0x00000002
#define MB_YESNOCANCEL              0x00000003
#define MB_YESNO                    0x00000004
#define MB_RETRYCANCEL              0x00000005
#define MB_CANCELTRYCONTINUE        0x00000006
#define MB_ICONHAND                 0x00000010
#define MB_ICONQUESTION             0x00000020
#define MB_ICONEXCLAMATION          0x00000030
#define MB_ICONASTERISK             0x00000040
#define MB_USERICON                 0x00000080
#define MB_DEFBUTTON2               0x00000100
#define MB_DEFBUTTON3               0x00000200
#define MB_DEFBUTTON4               0x00000300
#define MB_SYSTEMMODAL              0x00001000
#define MB_TASKMODAL                0x00002000
#define MB_HELP                     0x00004000
#define MB_NOFOCUS                  0x00008000
#define MB_SETFOREGROUND            0x00010000
#define MB_DEFAULT_DESKTOP_ONLY     0x00020000
#define MB_TOPMOST                  0x00040000
#define MB_RIGHT                    0x00080000
#define MB_RTLREADING               0x00100000

#define CSIDL_APPDATA               0x001a /* <username>\Application Data */
#define CSIDL_ADMINTOOLS            0x0030 /* <username>\Start Menu\Programs\Administrative Tools */

#define MAX_PATH 260

PROCEDURE Main()
   LOCAL hDLL
   LOCAL cData

   IF File( "pscript.dll" )
      hDLL := DllLoad( "pscript.dll" )
      cData := Space( 24 )
      DllCall( hDll, NIL, "PSGetVersion", @cData )
      ? ">" + cData + "<"
      DllUnload( hDLL )

      // ; Testing failure 1
      hDLL := DllLoad( "pscript.dll" )
      cData := Space( 24 )
      DllCall( hDll, NIL, "PSGet__Version", @cData )
      ? ">" + cData + "<"
      DllUnload( hDLL )
   ENDIF

   // ; Testing failure 2
   hDLL := DllLoad( "nothere.dll" )
   cData := Space( 24 )
   DllCall( hDll, NIL, "PSGetVersion", @cData )
   ? cData
   DllUnload( hDLL )

   ? "MsgBox:", DllCall( "user32.dll", NIL, "MessageBoxA", 0, "Hello world!", "Harbour sez", hb_bitOr( MB_OKCANCEL, MB_ICONEXCLAMATION, MB_HELP ) )

   IF File( "libcurl.dll" )
      hDLL := DllLoad( "libcurl.dll" )
      ? GetProcAddress( hDLL, "curl_version" )
      // ; This one doesn't work.
      ? CallDllTyped( 10 /* return string */, GetProcAddress( hDLL, "CURL_VERSION" ) )
      DllUnload( hDLL )
   ENDIF

   /* Force Windows not to show dragged windows contents */

   #define SPI_SETDRAGFULLWINDOWS 37

   ? "Full content drag: OFF"
   ? DllCall( "user32.dll", NIL, "SystemParametersInfo", SPI_SETDRAGFULLWINDOWS, 0, 0, 0 )
   Inkey( 0 )

   ? "Full content drag: ON"
   ? DllCall( "user32.dll", NIL, "SystemParametersInfo", SPI_SETDRAGFULLWINDOWS, 1, 0, 0 )
   Inkey( 0 )

   /* Get some standard Windows folders */

   hDLL := DllLoad( "shell32.dll" )
   ? ValType( hDLL )
   cData := Space( MAX_PATH )
   ? CallDllBool( GetProcAddress( hDLL, "SHGetSpecialFolderPath" ), 0, @cData, CSIDL_APPDATA, 0 )
   ? cData
   ? CallDll( GetProcAddress( hDLL, "SHGetFolderPath" ), 0, CSIDL_ADMINTOOLS, 0, 0, @cData )
   ? cData
   DllUnload( hDLL )

   RETURN

Código: Selecionar todos

library testando;

uses
  SysUtils,
  Classes;

  Function TESTE(cteste : CHAR) : CHAR ; cdecl;
   begin
     if cteste = 'A' Then
        Result := 'A'
     Else
        Result := 'X';
   End;

{$R *.res}

begin
end.
 

Código: Selecionar todos

@ 7,31 say 'Verificando teste '
hDLL := hb_LibLoad("testando.dll")
retorno := hb_dynCall( { "TESTE", hDLL , hb_bitOr( HB_DYN_CTYPE_CHAR , HB_DYN_CALLCONV_CDECL) } , 'T')
hb_LibFree(hDLL)
@ 7,65 say retorno

Código: Selecionar todos

      @ 7,31 say 'Verificando teste '
      hDLL := hb_LibLoad("testando.dll")
      cRetorno := '.'
      retorno := hb_dynCall( { "TESTE", hDLL , HB_DYN_CALLCONV_CDECL } , 'T' , @cRetorno )
      hb_LibFree(hDLL)
      @ 7,65 say retorno
      ?? " " + cRetorno

Código: Selecionar todos

cStatus:=hb_dynCall( { "DiaSemana", "Project2.dll",hb_bitOr( HB_DYN_CTYPE_CHAR_PTR , HB_DYN_CALLCONV_STDCALL )},'11/06/2012')

Código: Selecionar todos

library Project2;

{ Important note about DLL memory management: ShareMem must be the
  first unit in your library's USES clause AND your project's (select
  Project-View Source) USES clause if your DLL exports any procedures or
  functions that pass strings as parameters or function results. This
  applies to all strings passed to and from your DLL--even those that
  are nested in records and classes. ShareMem is the interface unit to
  the BORLNDMM.DLL shared memory manager, which must be deployed along
  with your DLL. To avoid using BORLNDMM.DLL, pass string information
  using PChar or ShortString parameters. }

uses
  SysUtils,
  Classes,
  WinTypes,
  WinProcs,
  Dialogs;

{declaração de uma função MaiorValor}

{$R *.res}
function Triple(N: Integer): Integer; stdcall;
begin
Result := N * 3;
end;

function Double (N: Integer): Integer; stdcall;
begin
Result := N * 2;
end;

function DiaSemana(Data: pchar): pAnsiChar; stdcall;
{Retorna o dia da semana em Extenso de uma determinada data}
var
var1:string;
const
  Dias : Array[1..7] of String[07] = ('DOMINGO', 'SEGUNDA', 'TERCA','QUARTA','QUINTA', 'SEXTA','SABADO');
begin
  //showmessage(Data);
  var1   := Dias[DayOfWeek(strtodate(Data))];
  Result := pchar(var1);
end;

function TrimAllChar(const S:PChar; const ch : PChar) : pAnsiChar; stdcall;
var
  buf : String;
  var1: String;
  var2: String;
begin
  buf := S;
  Result := '';
  Var1   := '';
  {while Pos finds a blank}
  //showmessage(s);
  //showmessage(ch);
  while (Pos(ch, buf) > 0) do begin
    {copy the substrings before the blank in to Result}
    Var1   := Var1   + Copy(buf, 1, Pos(ch, buf) - 1);
    buf := Copy(buf, Pos(ch, buf) + 1, Length(buf) - Pos(ch, buf));
  end;
  var2:=var1;
  //showmessage(var2);
  {There will still be a remainder in buf, so copy remainder into Result}
  Result := pchar(Var2+ buf);
end;

function Nada(_s:pchar):PAnsiChar;stdcall;
var
teste: string;
teste2: string;
   begin
   teste:=_s;
   teste2:=_s;
   showmessage(teste);
   showmessage(inttostr(Length (_s)));
   showmessage('ESTOU NO DELPHI');
   Result:=pchar(teste);
end;

function pcDLLVersion:pchar;stdcall;
begin
showmessage('teste');
result:='1.0.0';
end;

exports
Triple, Double, TrimAllChar, DiaSemana, Nada, pcDLLVersion;
end.

Código: Selecionar todos

library testando;

uses
 SysUtils,
 Classes;

 Function TESTE(cteste : CHAR) : CHAR ; cdecl;
 begin
  if cteste = 'A' Then
    Result := 'A'
  Else
    Result := 'X';
 End;

{$R *.res}

begin
end.
 

Código: Selecionar todos

library testando;

uses
 SysUtils,
 Classes;

{$R *.res}


Function TESTE( cTeste : pchar): pAnsiChar; stdcall;
Begin
  Result := pchar('X');
  if cTeste = 'A' then
     Result := pchar('A');

End;

exports TESTE;
end.