FAQ 【网络应用】

Emily

VBA可否检测出IP地址和工作组名称?

请参考【测出IP地址和工作组名称】

请参考【Get IP address】

如何在VBA中检查网络有无可用的Internet连接

请参考【如何在VBA中检查网络有无可用的Internet连接】

如何从网页插入指定图片在 WorkSheet 内

Cells(3, 3).Select ActiveSheet.Pictures.Insert "http://club.excelhome.net/UploadFile/2004-9/2004917204418292.jpg"

如何用VBA控制 IE

请参考【如何用VBA控制IE】4/F; 8/F

[此贴子已经被作者于2005-5-7 11:53:36编辑过]

Emily

' By chijanzen

Private Declare Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Long

Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long      ' 此一資料結構的大小
dwMajorVersion As Long          ' 版本主編號, 例如 4.0.950 的 4
dwMinorVersion As Long          ' 版本次編號, 例如 4.0.950 的 0
dwBuildNumber As Long           ' 版本建立編號, 例如 4.0.950 的 950
dwPlatformId As Long            ' 作業平臺
szCSDVersion As String * 128    ' 版本的進一步說明
End Type
Public lpVersionInformation As OSVERSIONINFO
'VER_PLATFORM_WIN32s(= 0) Win32s, 可在 Win 3.1 底下執行 32 位元元應用程式的平臺
'VER_PLATFORM_WIN32_Windows(= 1)  Windows 95 或 98
'VER_PLATFORM_WIN32_NT(= 2)  Windows NT 或 200 或 XP

Sub ShowWVersion()
Dim s As String, a As String
a = OperatingSystem
Select Case a
Case 0: s = "Windows 32"
Case 1: s = "Windows 95"
Case 2: s = "Windows 98"
Case 3: s = "Windows ME"
Case 4: s = "Windows NT"
Case 5: s = "Windows 2000"
Case 6: s = "Windows XP"
End Select
MsgBox s
End Sub

Sub test()
MsgBox Application.OperatingSystem
End Sub

Public Function OperatingSystem() As Integer
lpVersionInformation.dwOSVersionInfoSize = Len(lpVersionInformation)
Call GetVersionExA(lpVersionInformation)
If (lpVersionInformation.dwPlatformId = 0) Then 'VER_PLATFORM_WIN32s(= 0) Win32s _
,可在 Win 3.1 底下執行 32 位元元應用程式的平臺
OperatingSystem = 0
    
ElseIf (lpVersionInformation.dwPlatformId = 1) And _
(lpVersionInformation.dwMinorVersion = 0) Then   'Win95:VER_PLATFORM_WIN32_Windows(= 1) _
dwMinorVersion = 0
OperatingSystem = 1
    
ElseIf (lpVersionInformation.dwPlatformId = 1) And _
(lpVersionInformation.dwMinorVersion = 10) Then   'Win98:VER_PLATFORM_WIN32_Windows(= 1) _
dwMinorVersion = 10
OperatingSystem = 2
    
ElseIf (lpVersionInformation.dwPlatformId = 1) And _
(lpVersionInformation.dwMinorVersion = 90) Then   'WinMe:VER_PLATFORM_WIN32_Windows(= 1) _
dwMinorVersion = 90
OperatingSystem = 3
    
ElseIf (lpVersionInformation.dwPlatformId = 2) And _
(lpVersionInformation.dwMajorVersion < 5) Then    'WinNT:VER_PLATFORM_WIN32_Windows(= 1) _
dwMinorVersion < 5
OperatingSystem = 4
    
ElseIf (lpVersionInformation.dwPlatformId = 2) And _
(lpVersionInformation.dwMajorVersion = 5) And _
(lpVersionInformation.dwMinorVersion = 0) Then    'Win2000:VER_PLATFORM_WIN32_Windows(= 1) _
dwMinorVersion=5 and dwMinorVersion = 0
OperatingSystem = 5
    
ElseIf (lpVersionInformation.dwPlatformId = 2) And _
(lpVersionInformation.dwMajorVersion = 5) And _
(lpVersionInformation.dwMinorVersion = 1) Then    'WinXP:VER_PLATFORM_WIN32_Windows(= 1) _
dwMinorVersion=5 and dwMinorVersion = 0
OperatingSystem = 6
    
End If
End Function

[此贴子已经被作者于2006-9-23 19:14:10编辑过]

Emily

Option Explicit

'///////////
'//  IFM  //
'///////////

'// My thanks to "venky_dude"
'// Code modified for XP+ 26 may 2002 by Ivan F Moala
'// Errors in Type declaration on
'// platforms that don't support
'// wServicePackMajor As Integer 'NB some Platforms returns 0 and Not 1
'// wServicePackMinor As Integer 'NB some Platforms returns 0 and Not 1
'// wSuiteMask As Integer        'NB some Platforms returns 0 and Not 1
'// wProductType As Byte         'NB some Platforms returns 0 and Not 1
'// wReserved As Byte            'NB some Platforms returns 0 and Not 1
'// Testing done by MVP Members

Private Declare Function GetVersionEx _
    Lib "kernel32" _
    Alias "GetVersionExA" ( _
    lpVersionInformation As OSVERSIONINFO) _
As Long

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformId        As Long
    szCSDVersion        As String * 128
End Type

Sub Tester()
MsgBox OS_Version
End Sub

Function OS_Version() As String
Dim Os As OSVERSIONINFO
Dim m As Long
Dim MjV As Long
Dim PId As Long
Dim MnV As Long

Os.dwOSVersionInfoSize = Len(Os)

m = GetVersionEx(Os)
MjV = Os.dwMajorVersion
PId = Os.dwPlatformId

MnV = Os.dwMinorVersion

If PId = 2 Then
    '// NT,2000,XP
    Select Case Os.dwMajorVersion
    Case Is = 3
        OS_Version = " Windows NT 3." & Os.dwMinorVersion
    Case Is = 4
        OS_Version = " Windows NT 4 "
    Case Is = 5
        Select Case Os.dwMinorVersion
            '// win 2000
            Case Is = 0
                OS_Version = " Windows Windows 2000 "
            '// win XP or win .NET server
            Case Is = 1
                OS_Version = " Windows XP "
            Case Else
                OS_Version = " Windows .NET Server "
        End Select
    End Select
End If

If PId = 1 Then
    If MnV = 10 Then OS_Version = " Windows 98 "
    If MnV = 0 Then OS_Version = " Windows 95 "
    If MnV = 90 Then OS_Version = " Windows ME "
End If

End Function

[此贴子已经被作者于2006-10-3 12:50:24编辑过]

Emily

GAL - Gobal Address List by David Brett Tb44QSuq.zip (13.2 KB, 下载次数: 103)

2005-5-7 11:53 上传

点击文件名下载附件
FAQ 【网络应用】｛建立中｝

[em17]

Emily

'设定引用项目 Windows Script Host Object Model

Dim myWshNw  As IWshRuntimeLibrary.WshNetwork
Dim myStr As String
Set myWshNw = CreateObject("Wscript.Network")
myStr = myStr & "网域 = " & myWshNw.UserDomain & vbCrLf
myStr = myStr & "计算机名称 = " & myWshNw.ComputerName & vbCrLf
myStr = myStr & "使用者姓名 = " & myWshNw.UserName & vbCrLf
MsgBox myStr
Set myWshNw = Nothing

[此贴子已经被作者于2006-9-23 19:15:11编辑过]

Emily

'设定引用项目 Microsoft Internet Controls On Error Resume Next Set IE = New InternetExplorer IE.Navigate URL:="http://club.excelhome.net/index.asp" IE.Visible = True

Or

Dim Newsite As Object Set Newsite = CreateObject("InternetExplorer.application") Newsite.Visible = True Newsite.Navigate "http://club.excelhome.net/index.asp"

[此贴子已经被作者于2005-3-25 23:59:06编辑过]

secowu

以下是引用Emily在2005-1-6 0:33:00的发言： '设定引用项目 Windows Script Host Object Model

Dim myWshNw As IWshRuntimeLibrary.WshNetwork Dim myStr As String Set myWshNw = CreateObject("Wscript.Network") myStr = myStr & "网域 = " & myWshNw.UserDomain & vbCrLf myStr = myStr & "计算机名称 = " & myWshNw.ComputerName & vbCrLf myStr = myStr & "使用者姓名 = " & myWshNw.UserName & vbCrLf MsgBox myStr Set myWshNw = Nothing

Dim myWshNw As IWshRuntimeLibrary.WshNetwork

用户定义类型未定义

Emily

Method 1:

需引用 Microsoft Internet Control, Microsoft Shell Controls and Autom

Sub ListShellWindows()
' Written by Herilane orginally post in Xtreme
' Get all currently open IE and Explorer windows (those are based on the same class).
' For IE windows, get location. For WE windows, get path.
' Reference to Microsoft Internet Controls and to Microsoft Shell Controls and Automation

    Dim objShell As Shell
    Dim objIE As InternetExplorer
    Dim objExplorer As ShellFolderView
    Dim obj As Object
    Dim x As Integer

    x = 1
    Set objShell = New Shell
    For Each obj In objShell.Windows
        If TypeName(obj.Document) = "HTMLDocument" Then
            Set objIE = obj
            'Debug.Print objIE.LocationURL
            Cells(x, 1).Value = objIE.LocationURL
            x = x + 1
        Else
            Set objExplorer = obj.Document
            'Debug.Print objExplorer.FocusedItem.Path
            MsgBox objExplorer.FocusedItem.Path
        End If
    Next obj

End Sub

'

Method 2:

需引用 Microsoft Internet Controls

Sub IE_URL2()

Dim dWinFolder As New ShellWindows
Dim objIE As Object
Dim objDoc As Object

x = 1
For Each objIE In dWinFolder
Set Doc = objIE.Document
If TypeName(Doc) = "HTMLDocument" Then
    Cells(x, 1) = objIE.LocationURL
    x = x + 1
End If
Next
End Sub

Emily

有些網站不僅要 UserName 及 Password ，還有特別要求。以下代碼嘗試登陸 OFFICE精英俱部。代碼是 crdotlin 編寫，我修改小小。(有驗證不適用, eg ExcelHome )

Option Explicit

Dim myIE As InternetExplorer

Dim myIEdoc As HTMLDocument

Dim theForm As HTMLFormElement

 

Sub OpenWebpageAndLogin(URL As String, myPW As String, myID As String, _

    Optional myAns As String, Optional selItem As Integer)

Dim theItm As HTMLFormElement

Dim i As Integer

Dim Testing As Variant

Dim flg As Boolean

Set myIE = New InternetExplorer

With myIE

    .Navigate URL

    .Visible = True

    Do While .Busy: DoEvents: Loop

    Do While .ReadyState <> 4: DoEvents: Loop

End With

Set myIEdoc = myIE.Document

Set theForm = findFm(myIEdoc, "password")

With theForm

    For i = 0 To .Length - 1

    Testing = .Item(i).Name

        Select Case .Item(i).Name

            Case "password"

                .Item(i).Value = myPW

                flg = True

            Case "username"

                .Item(i).Value = myID

            Case "answer"

                .Item(i).Value = myAns

            Case "questionid"

                .Item(i).Value = selItem    'the quation's number

            Case Else

        End Select

    Next

End With

If flg Then

    Set theForm = findFm(myIEdoc, "submit")

Else

    myIE.Quit

    MsgBox ("Unexpected Error, I'm quitting.")

End If

Set myIE = Nothing

End Sub

 

 

Function findFm(theDoc As HTMLDocument, theType As String) As HTMLFormElement

    Dim i As Integer, j As Integer

    Dim theItm As HTMLFormElement

    With theDoc.forms

        For i = 0 To .Length - 1

            Set theItm = .Item(i)

            With theItm

                For j = 0 To .Length - 1

                    If .Item(j).Type = theType Then

                        Set findFm = theItm

                        If theType = "submit" Then .Item(j).Click

                        Exit Function

                    End If

                Next

            End With

        Next

    End With

End Function

 

Sub Test()

   OpenWebpageAndLogin URL:="http://www.officefans.net/cdb/logging.php?action=login", _

    myPW:="xxxxxx", myID:="Emily", myAns:="xxxx", selItem:=7

End Sub

'

參看 有關討論

直接下載  (另附自動新增引用項目)

Emily

以下介紹一段登陸網站的代碼，此代碼嘗試找出 登陸 HTML Form 內的 UserName 及 Password 位置然後自動填入。

'

' Set reference to Microsoft HTML Object Library

' Set Reference to Microsoft Internet Controls

'

 

Option Explicit

 

Dim myIE As InternetExplorer

Dim myIEdoc As HTMLDocument

Dim theForm As HTMLFormElement

 

Sub OpenWebpageAndLogin(URL As String, myPW As String, myID As String)

Dim theItm As HTMLFormElement

Dim i As Integer

Dim flg As Boolean

Set myIE = New InternetExplorer

With myIE

    .Navigate URL

    .Visible = True

    Do While .Busy: DoEvents: Loop

    Do While .ReadyState <> 4: DoEvents: Loop

End With

Set myIEdoc = myIE.Document

Set theForm = findFm(myIEdoc)

With theForm

    For i = 0 To .Length - 1

        Select Case .Item(i).Type

            Case "password"

                .Item(i).Value = myPW

                flg = True

            Case "text"

                .Item(i).Value = myID

            Case Else

        End Select

    Next

End With

If flg Then

    theForm.submit

Else

    myIE.Quit

    MsgBox ("Unexpected Error, I'm quitting.")

End If

Set myIE = Nothing

End Sub

 

Function findFm(theDoc As HTMLDocument) As HTMLFormElement

    Dim i As Integer, j As Integer

    Dim theItm As HTMLFormElement

    With theDoc.forms

        For i = 0 To .Length - 1

            Set theItm = .Item(i)

            With theItm

                For j = 0 To .Length - 1

                    If .Item(j).Type = "password" Then

                        Set findFm = theItm

                        Exit Function

                    End If

                Next

            End With

        Next

    End With

End Function

 

Sub Test()

  OpenWebpageAndLogin "http://mysinablog.com/admin.php", "Password", "UserName"

End Sub