Delphi调用api函数ShellExecute的问题！

[wildwolf_zb]

各位高手开发人员：
我这里有一个小问题，请教。我用Delphi写的用ShellExecute调用程序打开网页。我们单位计算机都有固定ip地址。具体过程如下：首先，判断是否在局域网内，192.168.10为判断条件符合的打开a网页，不符合打开b网页。但是现在出现一个问题如果某一台计算机ip也为192.168.10开头但是不在单位局域网内，且需要打开b网页，这种情况我的调用程序怎么做？我的思路是判断是否能打开a网页，如果打不开那打开b网页，但是ShellExecute函数没有这样的返回值，有一个返回句柄为SE_ERR_DDEFAIL = 29但是不成功。请高手指教！代码见下：
procedure TForm1.FormCreate(Sender: TObject);
begin
edit1.text:=GetHostName;
edit2.text:=NameToIP(edit1.Text);
if (LeftStr(edit2.text,3)='192') and (midstr(edit2.Text,5,3)='168') and (midstr(edit2.Text,9,2)='10') then
ShellExecute(handle,nil,pchar('http://a),nil,nil,SW_SHOWNORMAL)
else
ShellExecute(handle,nil,pchar('http://b),nil,nil,SW_SHOWNORMAL);
end;

[Forever_Young]

ping网关地址不行啊，ping通了就说明在局域网内，不通就不在了。

[差布多先生]

网关……

[dianyancao]

比如 a网页网站为：FJ-DNS.fz.fj.cn

可以用如下代码测试。

Option Explicit

Private Const WS_VERSION_REQD = &H101
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128

Private Type HOSTENT
      hname   As Long
      hAliases   As Long
      hAddrType   As Integer
      hLength   As Integer
      hAddrList   As Long
End Type
Private Type WSADATA
      wversion   As Integer
      wHighVersion   As Integer
      szDescription(0 To WSADescription_Len)       As Byte
      szSystemStatus(0 To WSASYS_Status_Len)       As Byte
      iMaxSockets   As Integer
      iMaxUdpDg   As Integer
      lpszVendorInfo   As Long
End Type
Private Declare Function WSAStartup Lib "WSOCK32.DLL " (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL " () As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL " (ByVal Hostname$) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32 " (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)

Public Function GetIP(Hostname As String) As String
      Dim WSAD     As WSADATA
      Dim iReturn     As Integer
      iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
      
      Dim hostent_addr As Long
      Dim host As HOSTENT
      Dim hostip_addr As Long
      Dim temp_ip_address() As Byte
      Dim i As Integer
      DoEvents
      hostent_addr = gethostbyname(Hostname)
      If hostent_addr = 0 Then
            GetIP = ""                                               '主机名不能被解释
            Exit Function
      End If
      RtlMoveMemory host, hostent_addr, LenB(host)
      RtlMoveMemory hostip_addr, host.hAddrList, 4
      ReDim temp_ip_address(1 To host.hLength)
      RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
      For i = 1 To host.hLength
            GetIP = GetIP & temp_ip_address(i) & "."
      Next
      GetIP = Mid$(GetIP, 1, Len(GetIP) - 1)
         
      Dim lReturn As Long
      lReturn = WSACleanup()
End Function

Public Function GetInternetConnectStatus() As Boolean
  If GetIP("FJ-DNS.fz.fj.cn") <> "" Then
    GetInternetConnectStatus = True
  Else
    GetInternetConnectStatus = False
  End If
End Function

[gyk120]

我觉得，你能不能用cmd命令，接受返回值呢？

[dianyancao]

可以的，但是很难看！

例子：获取CMD的返回值

Option Explicit

Private Sub Command1_Click()
  Dim strTarget As String
  Dim strPingResults As String
  Dim objWShell As Object
  Dim objWExec As Object
  strTarget = "www.google.com" 'IP address or hostname
  Set objWShell = CreateObject("WScript.Shell")
  Set objWExec = objWShell.Exec("ping -n 3 -w 1000 " & strTarget)
  DoEvents
  strPingResults = LCase(objWExec.StdOut.ReadAll)
  If InStr(strPingResults, "reply from ") Then
    MsgBox strPingResults
  Else
    MsgBox "no"
  End If
End Sub

[dianyancao]

哦,贴错代码了5

[dianyancao]

提供一个接口就可以了，佛爱我羊老兄，呵呵

修改下代码，写批处理对 Young 来说，是轻而易举的事，呵呵。

Option Explicit

Private Sub Command1_Click()
  Dim strTarget As String
  Dim strPingResults As String
  Dim objWShell As Object
  Dim objWExec As Object
  strTarget = "www.google.com" 'IP address or hostname
  Set objWShell = CreateObject("WScript.Shell")
  Set objWExec = objWShell.Exec("c:\IfLocal.bat")
  DoEvents
  strPingResults = LCase(objWExec.StdOut.ReadAll)
  If InStr(strPingResults, "key key key key") Then
    MsgBox strPingResults
  Else
    MsgBox "no"
  End If
End Sub

[dianyancao]

任务交给老兄了，呵呵

[Forever_Young]

[Quote=引用 17 楼 dianyancao 的回复:]
任务交给老兄了，呵呵
[/Quote]

delphi的ping工作还不至于需要批处理来代劳吧

[dianyancao]

那用这个吧，用来尝试是否能访问网关。
先获取 WMI 本机IP地址, 将第四个字节修改为 .1

然后再看看是否能够访问这个网关。呵呵
网关：xxx.xxx.xxx.1
[Quote=引用 11 楼 dianyancao 的回复:]

比如 a网页网站为：FJ-DNS.fz.fj.cn

可以用如下代码测试。
VB code
Option Explicit

Private Const WS_VERSION_REQD = &H101
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128

Private Type……
[/Quote]

[dianyancao]

IP解析.frm

Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128

Private Type HOSTENT
      hname   As Long
      hAliases   As Long
      hAddrType   As Integer
      hLength   As Integer
      hAddrList   As Long
End Type

Private Type WSADATA
      wversion   As Integer
      wHighVersion   As Integer
      szDescription(0 To WSADescription_Len)       As Byte
      szSystemStatus(0 To WSASYS_Status_Len)       As Byte
      iMaxSockets   As Integer
      iMaxUdpDg   As Integer
      lpszVendorInfo   As Long
End Type
Private Declare Function gethostbyaddr Lib "WSOCK32.DLL " (addr As Any, ByVal _
byteslen As Integer, addrtype As Integer) As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL " () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL " (ByVal _
                wVersionRequired&, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL " () As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL " (ByVal _
                hostname$) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32 " (hpvDest As Any, _
                ByVal hpvSource&, ByVal cbCopy&)

Function hibyte(ByVal wParam As Integer)                 '获得整数的高位
      hibyte = wParam \ &H100 And &HFF&
End Function

Function lobyte(ByVal wParam As Integer)                 '获得整数的低位
      lobyte = wParam And &HFF&
End Function

Function SocketsInitialize()
      Dim WSAD     As WSADATA
      Dim iReturn     As Integer
      Dim sLowByte     As String, sHighByte       As String, sMsg       As String
      
      iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
      
      If iReturn <> 0 Then
            MsgBox "Winsock.dll   没有反应. "
            End
      End If
      
      If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then
            sHighByte = Trim$(str$(hibyte(WSAD.wversion)))
            sLowByte = Trim$(str$(lobyte(WSAD.wversion)))
            sMsg = "Windows   Sockets版本   " & sLowByte & ". " & sHighByte
            sMsg = sMsg & "   不被winsock.dll支持   "
            MsgBox sMsg
            End
      End If
      
      If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
            sMsg = "这个系统需要的最少Sockets数为   "
            sMsg = sMsg & Trim$(str$(MIN_SOCKETS_REQD))
            MsgBox sMsg
            End
      End If
      
End Function

Sub SocketsCleanup()
      Dim lReturn     As Long
      
      lReturn = WSACleanup()
      
      If lReturn <> 0 Then
            MsgBox "Socket错误   " & Trim$(str$(lReturn)) & "   occurred   in   Cleanup   "
            End
      End If
End Sub


Sub Form_Load()
        '初始化Socket
        SocketsInitialize
End Sub

Private Sub Form_Unload(Cancel As Integer)
        '清除Socket
        SocketsCleanup
End Sub
Private Function getip(name As String) As String
      Dim hostent_addr     As Long
      Dim host     As HOSTENT
      Dim hostip_addr     As Long
      Dim temp_ip_address()     As Byte
      Dim i     As Integer
      Dim ip_address     As String
      
      hostent_addr = gethostbyname(name)
      
      If hostent_addr = 0 Then
            getip = " "                                               '主机名不能被解释
            Exit Function
      End If
      
      RtlMoveMemory host, hostent_addr, LenB(host)
      RtlMoveMemory hostip_addr, host.hAddrList, 4
      
      ReDim temp_ip_address(1 To host.hLength)
      RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
      
      For i = 1 To host.hLength
            ip_address = ip_address & temp_ip_address(i) & ". "
      Next
      ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
      
      getip = ip_address

End Function

Private Sub Command1_click()
        Dim str     As String
        str = getip(Text1.Text)
        If str = " " Then
                Text2.Text = "主机名不能被解释 "
        Else
                Text2.Text = str
        End If
End Sub
Private Function getname(addrstr As String) As String
        Dim hostent_addr     As Long
        Dim host     As HOSTENT
        Dim addr(0 To 50)         As Byte
        Dim addrs     As String
        Dim hname(1 To 50)         As Byte
        Dim str     As String
        Dim i     As Integer, j       As Integer
        Dim temp_int     As Integer
        Dim byt     As Byte
        str = Trim$(addrstr)
        i = 0
        j = 0
        Do
                temp_int = 0
                i = i + 1
                Do While Mid$(str, i, 1) >= "0 " And Mid$(str, i, 1) <= "9 " And i <= Len(str)
                        temp_int = temp_int * 10 + Mid$(str, i, 1)
                        i = i + 1
                Loop
                If temp_int <= 255 Then
                        addr(j) = temp_int
                        j = j + 1
                End If
        
        Loop Until Mid$(str, i, 1) <> ". " Or i > Len(str) Or temp_int > 255
        If temp_int > 255 Then
                getname = "地址非法 "
                Exit Function
        End If
        hostent_addr = gethostbyaddr(addr(0), j, 2)
        If hostent_addr = 0 Then
                getname = "此地址无法解析 "
                Exit Function
        End If
        RtlMoveMemory host, hostent_addr, LenB(host)
        RtlMoveMemory hname(1), host.hname, 50
        j = 51
        For i = 1 To 50
                If hname(i) = 0 Then
                        j = i
                End If
                If i >= j Then
                        hname(i) = 32
                End If
        Next i
        getname = Trim$(StrConv(hname, vbUnicode))
End Function
Private Sub Command2_Click()
        Dim name     As String
        name = getname(Text2.Text)
        If name = " " Then
                name = "此地址没有域名 "
        End If
        Text1.Text = name
End Sub

[dianyancao]

这个是WIndow的function IsNetworkAlive(lpdwFlags: PDWORD): Boolean; stdcall;
external 'sensapi.dll';
？

[dianyancao]

真是，原来是十二楼把我带进发、沟里

[Forever_Young]

[Quote=引用 27 楼 dianyancao 的回复:]
这个是WIndow的function IsNetworkAlive(lpdwFlags: PDWORD): Boolean; stdcall;
external 'sensapi.dll';
？
[/Quote]

肯定不是我封装的撒，呵呵

[shuwen186]

http://news.baidu.com/

我想写个程序。

大概的功能是：
1.类似定制版的浏览器。读取指定页面。http://news.baidu.com/然后软件上有个登陆窗口。不是在网页上登陆。直接在软件上用“按钮+文本框”登陆百度。
2.读取某网站的页面内容。获取他最新更新的新闻。并且自动刷新网页。在网页上有新闻的时候。弹出消息对话框。告诉我有最新新闻了。能弹出对话框的同时 要是能播放个音乐什么的最好了 。
3.读取网页指定区域。的指定内容。比如网站上的新闻列表。读出来在软件的Webbrowser控件界面上显示。出来。不是直接是浏览器。不需要读取这个页面。只要网页上的一部分内容就好了。
4.我不要再软件上让人看到百度广告等等垃圾消息。只要新闻。每隔20秒自动刷新一次。弹窗对话框或者语音。提示有新的新闻出来了。

看看有没有高手有现成的或者类似的源码的。
发给我邮箱：1617822579（at）qq.com 或者联系我qq# 1617822579

[Forever_Young]

[Quote=引用 11 楼 dianyancao 的回复:]
比如 a网页网站为：FJ-DNS.fz.fj.cn
可以用如下代码测试。
[/Quote]

这代码，闹心，简单问题都被你复杂化了，还是看俺们delphi的

[kye_jufei]

unit ping;    
  
interface  
  
uses  
  
Windows, SysUtils, Classes,  Controls, Winsock, StdCtrls;   
  
function pingip(ip:string):string;   
  
type  
  PIPOptionInformation = ^TIPOptionInformation;   
  TIPOptionInformation = packed record  
  TTL: Byte;   
  TOS: Byte;   
  Flags: Byte;   
  OptionsSize: Byte;   
  OptionsData: PChar;   
end;   
  
PIcmpEchoReply = ^TIcmpEchoReply;   
  TIcmpEchoReply = packed record  
  Address: DWORD;   
  Status: DWORD;   
  RTT: DWORD;   
  DataSize: Word;   
  Reserved: Word;   
  Data: Pointer;   
  Options: TIPOptionInformation;   
end;   
  
TIcmpCreateFile = function: THandle; stdcall;   
TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;   
TIcmpSendEcho = function( IcmpHandle:THandle;   
                          DestinationAddress: DWORD;   
                          RequestData: Pointer;   
                          RequestSize: Word;   
                          RequestOptions: PIPOptionInformation;   
                          ReplyBuffer: Pointer;   
                          ReplySize: DWord;   
                          Timeout: DWord   
                        ): DWord; stdcall;   
  
Tping =class(Tobject)   
  private  
    { Private declarations }  
    hICMP: THANDLE;   
    IcmpCreateFile : TIcmpCreateFile;   
    IcmpCloseHandle: TIcmpCloseHandle;   
    IcmpSendEcho: TIcmpSendEcho;   
  public  
    procedure   pinghost(ip:string;var info:string);   
    constructor create;   
    destructor destroy;override;   
    { Public declarations }  
end;   
  
var  
  hICMPdll: HMODULE;   
  
implementation  
  
constructor Tping.create;   
begin  
  inherited create;   
  hICMPdll := LoadLibrary('icmp.dll');   
  @ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');   
  @IcmpCloseHandle := GetProcAddress(hICMPdll,'IcmpCloseHandle');   
  @IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');   
  hICMP := IcmpCreateFile;   
end;   
  
destructor Tping.destroy;   
begin  
  FreeLibrary(hIcmpDll);   
  inherited destroy;   
end;   
  
  
procedure Tping.pinghost(ip:string;var info:string);   
var  
  // IP Options for packet to send   
  IPOpt:TIPOptionInformation;   
  FIPAddress:DWORD;   
  pReqData,pRevData:PChar;   
  // ICMP Echo reply buffer   
  pIPE:PIcmpEchoReply;   
  FSize: DWORD;   
  MyString:string;   
  FTimeOut:DWORD;   
  BufferSize:DWORD;   
begin  
  if ip<>'' then  
  begin  
    FIPAddress := inet_addr(PChar(ip));   
    FSize := 40;   
    BufferSize := SizeOf(TICMPEchoReply) + FSize;   
    GetMem(pRevData,FSize);   
    GetMem(pIPE,BufferSize);   
    FillChar(pIPE^, SizeOf(pIPE^), 0);   
    pIPE^.Data := pRevData;   
    MyString := 'Test Net - Sos Admin';   
    pReqData := PChar(MyString);   
    FillChar(IPOpt, Sizeof(IPOpt), 0);   
    IPOpt.TTL := 64;   
    FTimeOut := 4000;   
    try  
      IcmpSendEcho(hICMP, FIPAddress, pReqData, Length(MyString),@IPOpt, pIPE, BufferSize, FTimeOut);   
      if pReqData^ = pIPE^.Options.OptionsData^ then  
        info:=ip+ '　' + IntToStr(pIPE^.DataSize) + '　　　' +IntToStr(pIPE^.RTT);   
    except  
      info:='Can not find host!';   
      FreeMem(pRevData);   
      FreeMem(pIPE);   
      Exit;   
    end;   
    FreeMem(pRevData);   
    FreeMem(pIPE);   
  end;   
end;   
  
function pingip(ip:string):string;   
var  
  str:string;   
  ping:Tping;   
begin  
  ping:=Tping.create ; 
  ping.pinghost('www.baidu.com',str);   
  result:=str;   
  ping.destroy ;   
end;   
end.  

[kye_jufei]

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,ping;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  str:string;
  ping:Tping;
begin
  ping:=Tping.create;
  ping.pinghost('220.181.6.19',str);
  memo1.Lines.Add(str);
  ping.destroy;
end;


end.

[Forever_Young]

我刚开始我也被楼主的描述把思维都引诱到IP的识别上面去了，并且我还写出了个通过获取arp表来得到网关是否存活的代码，虽然也就20多行代码但总觉得有些化简为繁了的感觉，转念一想楼主不就是个判断LAN和WAN的要求么，呵呵。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ShellApi;

const
  NETWORK_ALIVE_LAN = 1;
  NETWORK_ALIVE_WAN = 2;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

function IsNetworkAlive(lpdwFlags: PDWORD): Boolean; stdcall;
external 'sensapi.dll';

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  ConnectType: DWORD;
begin
  if IsNetworkAlive(@ConnectType) then
    case ConnectType of
      NETWORK_ALIVE_LAN:
        ShellExecute(handle, nil, 'http://a', nil, nil, SW_SHOWNORMAL);
      NETWORK_ALIVE_WAN:
        ShellExecute(handle, nil, 'http://b', nil, nil, SW_SHOWNORMAL);
    end
  else
    ShowMessage('没有连接到网络');
end;

end.

[Forever_Young]

[Quote=引用 14 楼 dianyancao 的回复:]
哦,贴错代码了5
[/Quote]

我想的话，楼主不是要判断网络通不通，而是要判断是在内网还是外网，然后打开不同的网站，所以我觉得ping内网网关来判断简单准确，代码实现起来也很简单。

你的代码是拿来判断网通不通还行，判断是否内外网差老远了，呵呵。