完美Excel

Declare Function FindFirstFile Lib "kernel32" Alias _
   "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData _
   As WIN32_FIND_DATA) As Long
 
   Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
   (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
 
   Declare Function GetFileAttributes Lib "kernel32" Alias _
   "GetFileAttributesA" (ByVal lpFileName As String) As Long
 
   Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) _
   As Long
 
   Declare Function FileTimeToLocalFileTime Lib "kernel32" _
   (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
 
   Declare Function FileTimeToSystemTime Lib "kernel32" _
   (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
 
   Public Const MAX_PATH = 260
   Public Const MAXDWORD = &HFFFF
   Public Const INVALID_HANDLE_VALUE = -1
   Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
   Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
   Public Const FILE_ATTRIBUTE_HIDDEN = &H2
   Public Const FILE_ATTRIBUTE_NORMAL = &H80
   Public Const FILE_ATTRIBUTE_READONLY = &H1
   Public Const FILE_ATTRIBUTE_SYSTEM = &H4
   Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
 
   Type FILETIME
     dwLowDateTime As Long
     dwHighDateTime As Long
   End Type
 
   Type WIN32_FIND_DATA
     dwFileAttributes As Long
     ftCreationTime As FILETIME
     ftLastAccessTime As FILETIME
     ftLastWriteTime As FILETIME
     nFileSizeHigh As Long
     nFileSizeLow As Long
     dwReserved0 As Long
     dwReserved1 As Long
     cFileName As String * MAX_PATH
     cAlternate As String * 14
   End Type
 
   Type SYSTEMTIME
     wYear As Integer
     wMonth As Integer
     wDayOfWeek As Integer
     wDay As Integer
     wHour As Integer
     wMinute As Integer
     wSecond As Integer
     wMilliseconds As Integer
   End Type
 
   Public Function StripNulls(OriginalStr As String) As String
      If (InStr(OriginalStr, Chr(0)) > 0) Then
         OriginalStr = Left(OriginalStr, _
          InStr(OriginalStr, Chr(0)) - 1)
      End If
      StripNulls = OriginalStr
   End Function

Function FindFilesAPI(path As String, SearchStr As String, _
    FileCount As Integer, DirCount As Integer)
   Dim FileName As String   ' Walking filename variable...
   Dim DirName As String    ' SubDirectory Name
   Dim dirNames() As String ' Buffer for directory name entries
   Dim nDir As Integer   ' Number of directories in this path
   Dim i As Integer      ' For-loop counter...
   Dim hSearch As Long   ' Search Handle
   Dim WFD As WIN32_FIND_DATA
   Dim Cont As Integer
   Dim FT As FILETIME
   Dim ST As SYSTEMTIME
   Dim DateCStr As String, DateMStr As String
 
   If Right(path, 1) <> "\" Then path = path & "\"
   ' Search for subdirectories.
   nDir = 0
   ReDim dirNames(nDir)
   Cont = True
   hSearch = FindFirstFile(path & "*", WFD)
   If hSearch <> INVALID_HANDLE_VALUE Then
      Do While Cont
         DirName = StripNulls(WFD.cFileName)
         ' Ignore the current and encompassing directories.
         If (DirName <> ".") And (DirName <> "..") Then
            ' Check for directory with bitwise comparison.
            If GetFileAttributes(path & DirName) And _
             FILE_ATTRIBUTE_DIRECTORY Then
               dirNames(nDir) = DirName
               DirCount = DirCount + 1
               nDir = nDir + 1
               ReDim Preserve dirNames(nDir)
               ' Uncomment the next line to list directories
               'List1.AddItem path & FileName
            End If
         End If
         Cont = FindNextFile(hSearch, WFD)  ' Get next subdirectory.
      Loop
      Cont = FindClose(hSearch)
   End If
 
   ' Walk through this directory and sum file sizes.
   hSearch = FindFirstFile(path & SearchStr, WFD)
   Cont = True
   If hSearch <> INVALID_HANDLE_VALUE Then
      While Cont
         FileName = StripNulls(WFD.cFileName)
            If (FileName <> ".") And (FileName <> "..") And _
              ((GetFileAttributes(path & FileName) And _
               FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
            FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * _
             MAXDWORD) + WFD.nFileSizeLow
            FileCount = FileCount + 1
            ' To list files w/o dates, uncomment the next line
            ' and remove or Comment the lines down to End If
            'List1.AddItem path & FileName
            
           ' Include Creation date...
           FileTimeToLocalFileTime WFD.ftCreationTime, FT
           FileTimeToSystemTime FT, ST
           DateCStr = ST.wMonth & "/" & ST.wDay & "/" & ST.wYear & _
              " " & ST.wHour & ":" & ST.wMinute & ":" & ST.wSecond
           ' and Last Modified Date
           FileTimeToLocalFileTime WFD.ftLastWriteTime, FT
           FileTimeToSystemTime FT, ST
           DateMStr = ST.wMonth & "/" & ST.wDay & "/" & ST.wYear & _
              " " & ST.wHour & ":" & ST.wMinute & ":" & ST.wSecond
           ListBox1.AddItem path & FileName & vbTab & _
              Format(DateCStr, "mm/dd/yyyy hh:nn:ss") _
              & vbTab & Format(DateMStr, "mm/dd/yyyy hh:nn:ss")
          End If
         Cont = FindNextFile(hSearch, WFD)  ' Get next file
      Wend
      Cont = FindClose(hSearch)
   End If
 
   ' If there are sub-directories...
    If nDir > 0 Then
      ' Recursively walk into them...
      For i = 0 To nDir - 1
        FindFilesAPI = FindFilesAPI + FindFilesAPI(path & dirNames(i) _
         & "\", SearchStr, FileCount, DirCount)
      Next i
   End If
   End Function
 
   Private Sub CommandButton1_Click()
       Dim SearchPath As String, FindStr As String
       Dim FileSize As Long
       Dim NumFiles As Integer, NumDirs As Integer
 
       ListBox1.Clear
       SearchPath = TextBox1.Text
       FindStr = TextBox2.Text
       FileSize = FindFilesAPI(SearchPath, FindStr, NumFiles, NumDirs)
       TextBox3.Text = NumFiles & " Files found in " & NumDirs + 1 & _
             " Directories"
       TextBox4.Text = "Size of files found under " & SearchPath & " = " & _
       Format(FileSize, "#,###,###,##0") & " Bytes"
   End Sub

Function FindFiles(path As String, SearchStr As String, _
       FileCount As Integer, DirCount As Integer)
      Dim FileName As String   ' Walking filename variable.
      Dim DirName As String    ' SubDirectory Name.
      Dim dirNames() As String ' Buffer for directory name entries.
      Dim nDir As Integer      ' Number of directories in this path.
      Dim i As Integer         ' For-loop counter.

      On Error GoTo sysFileERR
      If Right(path, 1) <> "\" Then path = path & "\"
      ' Search for subdirectories.
      nDir = 0
      ReDim dirNames(nDir)
      DirName = Dir(path, vbDirectory Or vbHidden Or vbArchive Or vbReadOnly _
Or vbSystem)  ' Even if hidden, and so on.
      Do While Len(DirName) > 0
         ' Ignore the current and encompassing directories.
         If (DirName <> ".") And (DirName <> "..") Then
            ' Check for directory with bitwise comparison.
            If GetAttr(path & DirName) And vbDirectory Then
               dirNames(nDir) = DirName
               DirCount = DirCount + 1
               nDir = nDir + 1
               ReDim Preserve dirNames(nDir)
               'List2.AddItem path & DirName ' Uncomment to list
            End If                           ' directories.
sysFileERRCont:
         End If
         DirName = Dir()  ' Get next subdirectory.
      Loop
 
      ' Search through this directory and sum file sizes.
      FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem _
      Or vbReadOnly Or vbArchive)
      While Len(FileName) <> 0
         FindFiles = FindFiles + FileLen(path & FileName)
         FileCount = FileCount + 1
         ' Load List box
         ListBox2.AddItem path & FileName & vbTab & _
            FileDateTime(path & FileName)   ' Include Modified Date
         FileName = Dir()  ' Get next file.
      Wend
 
      ' If there are sub-directories..
      If nDir > 0 Then
         ' Recursively walk into them
         For i = 0 To nDir - 1
           FindFiles = FindFiles + FindFiles(path & dirNames(i) & "\", _
            SearchStr, FileCount, DirCount)
         Next i
      End If
 
AbortFunction:
      Exit Function
sysFileERR:
      If Right(DirName, 4) = ".sys" Then
        Resume sysFileERRCont ' Known issue with pagefile.sys
      Else
        MsgBox "Error: " & Err.Number & " - " & Err.Description, , _
         "Unexpected Error"
        Resume AbortFunction
      End If
      End Function
 
Private Sub CommandButton2_Click()
    Dim SearchPath As String, FindStr As String
    Dim FileSize As Long
    Dim NumFiles As Integer, NumDirs As Integer
 
    ListBox2.Clear
    SearchPath = TextBox1.Text
    FindStr = TextBox2.Text
    FileSize = FindFiles(SearchPath, FindStr, NumFiles, NumDirs)
    TextBox5.Text = NumFiles & " Files found in " & NumDirs + 1 & _
       " Directories"
    TextBox6.Text = "Size of files found under " & SearchPath & " = " & _
          Format(FileSize, "#,###,###,##0") & " Bytes"
End Sub
 
Private Sub userForm_Initialize()
    CommandButton1.Caption = "使用API代码"
    CommandButton2.Caption = "使用VBA代码"
    ' start with some reasonable defaults
    TextBox1.Text = "C:\Documents and Settings\m\My Documents"
    TextBox2.Text = "*.*"
End Sub

Function DoesFileExist(strFileSpec As String) As Boolean
    ' 如果参数strFileSpec指定的文件存在则返回True.
    ' 如果strFileSpec不是有效的文件或者是一个目录则返回False.
    Const INVALID_ARGUMENT As Long = 53
    On Error GoTo DoesfileExist_Err
    If (GetAttr(strFileSpec) And vbDirectory) <> vbDirectory Then
        DoesFileExist = CBool(Len(Dir(strFileSpec)) > 0)
    Else
        DoesFileExist = False
    End If
DoesfileExist_End:
    Exit Function
DoesfileExist_Err:
    DoesFileExist = False
    Resume DoesfileExist_End
End Function

Function GetAllFilesInDir(ByVal strDirPath As String) As Variant
    ' 遍历strDirPath中指定的目录并在数组中保存每个文件名
   ' 然后返回该数组到调用过程.
    ' 如果strDirPath不是一个有效的目录则返回False.
    Dim strTempName As String
    Dim varFiles() As Variant
    Dim lngFileCount As Long
 
    On Error GoTo GetAllFiles_Err
 
    ' 确保strDirPath以"\"字符结尾.
    If Right$(strDirPath, 1) <> "\" Then
        strDirPath = strDirPath & "\"
    End If
 
    ' 确保strDirPath是一个目录.
    If GetAttr(strDirPath) = vbDirectory Then
        strTempName = Dir(strDirPath, vbDirectory)
        Do Until Len(strTempName) = 0
            ' 排除 ".", "..".
            If (strTempName <> ".") And (strTempName <> "..") Then
                ' 确保没有子目录名称.
                If (GetAttr(strDirPath & strTempName) _
                    And vbDirectory) <> vbDirectory Then
                    ' 增加数组的大小以适应发现的文件名并将其添加到数组.
                    ReDim Preserve varFiles(lngFileCount)
                    varFiles(lngFileCount) = strTempName
                    lngFileCount = lngFileCount + 1
                End If
            End If
            ' 使用Dir函数查找下一个文件名.
            strTempName = Dir()
        Loop
        ' 返回包含已找到的文件名称的数组.
        GetAllFilesInDir = varFiles
    End If
GetAllFiles_End:
    Exit Function
GetAllFiles_Err:
    GetAllFilesInDir = False
    Resume GetAllFiles_End
End Function

Sub TestGetAllFiles()
    Dim varFileArray As Variant
    Dim lngI As Long
    Dim strDirName As String
 
    Const NO_FILES_IN_DIR As Long = 9
    Const INVALID_DIR As Long = 13
 
    On Error GoTo Test_Err
 
    strDirName = "c:\my documents"
    varFileArray = GetAllFilesInDir(strDirName)
    For lngI = 0 To UBound(varFileArray)
        Debug.Print varFileArray(lngI)
    Next lngI
 
Test_Err:
    Select Case Err.Number
        Case NO_FILES_IN_DIR
            MsgBox "The directory named '" & strDirName _
                & "' contains no files."
        Case INVALID_DIR
            MsgBox "'" & strDirName & "' is not a valid directory."
        Case 0
        Case Else
            MsgBox "Error #" & Err.Number & " - " & Err.Description
    End Select
End Sub

Dim dctDict As Scripting.Dictionary
Set dctDict = New Scripting.Dictionary

Dim fsoSysObj As Scripting.FileSystemObject
Set fsoSysObj = New Scripting.FileSystemObject

Function GetFiles(strPath As String, _
                dctDict As Scripting.Dictionary, _
                Optional blnRecursive As Boolean) As Boolean
 
   ' 本过程返回目录中的所有文件到Dictionary对象中.
   ' 如果递归调用则同时返回子文件夹中的所有文件.
   
   Dim fsoSysObj      As Scripting.FileSystemObject
   Dim fdrFolder      As Scripting.Folder
   Dim fdrSubFolder   As Scripting.Folder
   Dim filFile        As Scripting.File
 
   ' 返回新的FileSystemObject.
   Set fsoSysObj = New Scripting.FileSystemObject
 
   On Error Resume Next
   ' 获取文件夹.
   Set fdrFolder = fsoSysObj.GetFolder(strPath)
   If Err <> 0 Then
      ' 不正确的路径.
      GetFiles = False
      GoTo GetFiles_End
   End If
   On Error GoTo 0
 
   ' 遍历Files集合,添加到字典.
   For Each filFile In fdrFolder.Files
      dctDict.Add filFile.Path, filFile.Path
   Next filFile
 
   ' 如果Recursive标志为真,则递归调用.
   If blnRecursive Then
      For Each fdrSubFolder In fdrFolder.SubFolders
         GetFiles fdrSubFolder.Path, dctDict, True
      Next fdrSubFolder
   End If
 
   ' 如果没有错误发生则返回True.
   GetFiles = True
 
GetFiles_End:
   Exit Function
End Function
 
   ' 如果没有错误发生则返回True.
   GetFiles = True
 
GetFiles_End:
   Exit Function
End Function

Sub TestGetFiles()
   ' 测试GetFiles函数.

   Dim dctDict As Scripting.Dictionary
   Dim varItem As Variant
   Dim strDirPath As String
 
   strDirPath = "c:\my documents\"
   ' 创建新的字典.
   Set dctDict = New Scripting.Dictionary
   ' 递归调用, 返回文件到Dictionary对象.
   If GetFiles(strDirPath, dctDict, True) Then
      ' 打印字典中的项目.
      For Each varItem In dctDict
         Debug.Print varItem
      Next
   End If
End Sub

Function ChangeFileAttributes(strPath As String, _
                            Optional lngSetAttr As FileAttribute, _
                            Optional lngRemoveAttr As FileAttribute, _
                            Optional blnRecursive As Boolean) As Boolean
 
   ' 本函数接受一个目录路径, 一个指定文件属性设置的值
   ' 一个指定文件属性移除的值
   ' 一个指明是否递归调用的标志
   ' 如果没有发生错误则返回True.
   
   Dim fsoSysObj      As Scripting.FileSystemObject
   Dim fdrFolder      As Scripting.Folder
   Dim fdrSubFolder   As Scripting.Folder
   Dim filFile        As Scripting.File
 
   ' 返回新的FileSystemObject.
   Set fsoSysObj = New Scripting.FileSystemObject
 
   On Error Resume Next
   ' 获取文件夹.
   Set fdrFolder = fsoSysObj.GetFolder(strPath)
   If Err <> 0 Then
      ' 不正确的路径.
      ChangeFileAttributes = False
      GoTo ChangeFileAttributes_End
   End If
   On Error GoTo 0
 
   ' 如果调用者传递属性去设置则设置所有的.
   If lngSetAttr Then
      For Each filFile In fdrFolder.Files
         If Not (filFile.Attributes And lngSetAttr) Then
            filFile.Attributes = filFile.Attributes Or lngSetAttr
         End If
      Next
   End If
 
   ' 如果调用者传递属性去移除则移除所有的.
   If lngRemoveAttr Then
      For Each filFile In fdrFolder.Files
         If (filFile.Attributes And lngRemoveAttr) Then
            filFile.Attributes = filFile.Attributes - lngRemoveAttr
         End If
      Next
   End If
 
   ' 如果调用者设置blnRecursive参数为True,则递归调用函数.
   If blnRecursive Then
      ' 遍历子文件夹.
      For Each fdrSubFolder In fdrFolder.SubFolders
         ' 调用带有子文件夹路径的函数.
         ChangeFileAttributes fdrSubFolder.Path, lngSetAttr, _
            lngRemoveAttr, True
      Next
   End If
   ChangeFileAttributes = True
 
ChangeFileAttributes_End:
   Exit Function
End Function

Sub TestChangeAttributes()
    If ChangeFileAttributes("c:\my documents", , _
        Hidden, False) = True Then
        MsgBox "File attributes succesfully changed!"
    End If
End Sub

Function CustomFindFile(strFileSpec As String)
    ' 本过程演示一个简单的文件搜索程序
    ' 显示一个消息框,包含在"C:\"目录中与参数strFileSpec提供的文件规范相匹配的所有文件的名称
    ' 参数strFileSpec可以包含一个或多个在分号分隔列表中的文件规格.
    ' 例如,下面的strFileSpec参数返回"c:\"中包含扩展名"*.log;*.bat;*.ini"的包有文件
    
   Dim fsoFileSearch   As Office.FileSearch
    Dim varFile         As Variant
    Dim strFileList     As String
 
    ' 如果输入有效,那么处理文件搜索.
    If Len(strFileSpec) >= 3 And InStr(strFileSpec, "*.") > 0 Then
        Set fsoFileSearch = Application.FileSearch
        With fsoFileSearch
            .NewSearch
            .LookIn = "c:\"
            .Filename = strFileSpec
            .SearchSubFolders = False
            If .Execute() > 0 Then
                For Each varFile In .FoundFiles
                    strFileList = strFileList & varFile & vbCrLf
                Next varFile
            End If
        End With
        MsgBox strFileList
    Else
        MsgBox strFileSpec & " is not a valid file specification."
        Exit Function
    End If
End Function

Sub GetOpenFileNameExample3()
    Dim lCount As Long
    Dim vFilename As Variant
    Dim sPath As String
    Dim lFilecount As Long
    sPath = "c:\windows\temp\"
    ChDrive sPath
    ChDir sPath
    vFilename = Application.GetOpenFilename("Microsoft Excel files (*.xls),*.xls", , "Please select the file(s) to open", , True)
    If TypeName(vFilename) = "Boolean" Then Exit Sub
    For lCount = 1 To UBound(vFilename)
        Workbooks.Open vFilename(lCount)
    Next
End Sub

"Image files (*.jpg),*.jpg"

Sub OpenBooksInFolder()
 
    Dim FileFound As String, N As Long
    Dim Sheet As Worksheet, FilePath As String
 
     'stipulate the folders path here
    FilePath = "C:\Documents and Settings\m\桌面"
 
    DoEvents
    Application.ScreenUpdating = False
 
     'list all the books in the folder
    With Application.FileSearch
        .LookIn = FilePath
        .FileType = msoFileTypeExcelWorkbooks
 
         'this should gives partial matches
         'i.e. anything with 'happy' in the
         'name regardless of case
        .Filename = "水工"
 
         'false = only search given folder
        .SearchSubFolders = False
 
        On Error Resume Next
        If .Execute > 0 Then
            For N = 1 To .FoundFiles.Count
 
                 'Debug.Print .FoundFiles(N) '< make a choice
                Workbooks.Open (.FoundFiles(N)) '< make a choice
                 
                 'now do what you want to do
                 'with each open workbook
                 
            Next N
        Else
            MsgBox "The file " & .Filename & " was not found"
        End If
    End With
    Application.ScreenUpdating = True
End Sub

Sub LoopFolder()
    Const SourceFolder As String = "C:\Users\ianlane\Desktop\test bucket\"
    Dim oFSO
    Dim oFolder As Object
    Dim oFile As Object
    Dim NewFolder As String
 
    Set oFSO = CreateObject("Scripting.FileSystemObject")
 
    Set oFolder = oFSO.GetFolder(SourceFolder)
 
    For Each oFile In oFolder.Files
 
        If oFile.Type Like "*Comma Separated Values*" Then
            Select Case True
            Case oFile Like "*Bankhill*"
                NewFolder = "Bankhill\"
            Case oFile Like "*Lite*"
                NewFolder = "Lite\"
                 'etc
            End Select
            Name oFile.Path As SourceFolder & NewFolder & oFile.Name
        End If
    Next oFile
 
    Set oFolder = Nothing
    Set oFSO = Nothing
 
End Sub

' The posting by Billkamm at http://www.dailydoseofexcel.com/archives/2006/01/29/ftp-via-vba/
 ' http://www.access-programmers.co.uk/forums/attachment.php?attachmentid=13389&d=1145948437
 ' http://msdn2.microsoft.com/en-us/library/aa383996.aspx
 ' http://msdn2.microsoft.com/en-us/library/aa384363(VS.85).aspx
 ' http://msdn2.microsoft.com/en-us/library/aa384180(VS.85).aspx
 ' http://msdn2.microsoft.com/en-us/library/aa384157(VS.85).aspx
 ' http://msdn2.microsoft.com/en-us/library/aa384166(VS.85).aspx
 ' http://www.devx.com/getHelpOn/10MinuteSolution/20373/1763
 
 
 ' Open the Internet object
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
 
 ' Connect to the network
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, _
ByVal nServerPort As Integer, ByVal sUsername As String, _
ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
 
 ' Get a file using FTP
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" _
(ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, _
ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Boolean
 
 ' Send a file using FTP
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Boolean
 
 ' Close the Internet object
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
 
Sub GetORD_TXT()
 
     ' This sub uses the above functions to get a particular text file stored on the NOAA servers.  (It is the aviation
     ' weather report for Chicago O'Hare.)  This is very basic "proof of concept" code to demonstrate to myself that
     ' the above functions work (they do!) and what I need to be doing when I call them.
     '
     ' This routine will get the KORD.TXT file from the NOAA server and place it in the C:\ directory on my computer.
     '
     ' I've commented out the uninteresting MsgBox lines; they show long (and meaningless) numbers.
     '
     
    Dim AgentStr As String
    Dim AccessTypeLong As Long
    Dim ProxyNameStr As String
    Dim ProxyBypassStr As String
    Dim FlagsLong As Long
 
    Dim InternetSessionLong As Long
    Dim ServerNameStr As String
    Dim ServerPortInt As Integer
    Dim UserNameStr As String
    Dim PasswordStr As String
    Dim ServiceLong As Long
    Dim ContextLong As Long
 
    Dim FTPSessionLong As Long
    Dim RemoteFileStr As String
    Dim NewFileStr As String
    Dim FailIfExistsBool As Boolean
    Dim FlagsAndAttributesLong As Long
 
    Dim SomeThingLong As Long
    Dim MyInternetHandleLong As Long
    Dim MyFTPHandleLong As Long
    Dim SomeInteger As Integer
    Dim FTPSuccessBool As Boolean ' Did the FTP download work?
     
     ' ********************************
     ' **                            **
     ' **  Call INTERNET OPEN first  **
     ' **                            **
     ' ********************************
     
    AgentStr = "GreenTreeTest" ' can be whatever
    AccessTypeLong = 0 ' zero appears to work fine
    ProxyNameStr = "" ' nul works fine here
    ProxyBypassStr = "" ' nul works fine here
    FlagsLong = 0 ' zero appears to work fine
     
    MyInternetHandleLong = InternetOpen(AgentStr, AccessTypeLong, ProxyNameStr, ProxyBypassStr, FlagsLong)
 
     ' MsgBox MyInternetHandleLong
     
 
     ' *********************************
     ' **                             **
     ' **  Call Internet CONNECT next **
     ' **                             **
     ' *********************************
     
     ' The file I want to get is at ftp://tgftp.nws.noaa.gov/data/observations/metar/stations/KORD.TXT
     
     'MyInternetHandleLong is obtained above
    ServerNameStr = "tgftp.nws.noaa.gov" ' address of the FTP server, WITHOUT the "ftp://" part
    ServerPortInt = 21 ' default FTP port
    UserNameStr = "anonymous" ' "anonymous" is the is the default
    PasswordStr = "" ' nul is the default
    ServiceLong = 1 ' this for the FTP service (2 = gopher, 3 = http)
    FlagsLong = 0 ' 0 appears to work fine here
    ContextLong = 0 ' 0 appears to work fine here
     
    MyFTPHandleLong = InternetConnect(MyInternetHandleLong, ServerNameStr, ServerPortInt, UserNameStr, PasswordStr, ServiceLong, FlagsLong, ContextLong)
 
     ' MsgBox "My FTP handle = " & MyFTPHandleLong
     ' (this is NOT the same value as MyInternetHandle, above)
     
 
     ' *****************************
     ' **                         **
     ' **  Call FTP Get File next **
     ' **                         **
     ' *****************************
     
     ' MyFTPHandleLong is obtained above
    RemoteFileStr = "/data/observations/metar/stations/KORD.TXT" ' file name on server, including directories
    NewFileStr = "C:\KORD.txt" ' file name on MY system
    FailIfExistsBool = False ' should NOT fail if file already exists on MY computer.... HOWEVER,
     '  if the file does exist, the FTP DOES fail.  Don't know about this.  Short answer:
     '  the target file should NOT exist on my computer before calling this routine!
    FlagsAndAttributesLong = 128 ' Normal file, no special flags set.
    FlagsLong = 2 ' FTP Transfer Type Binary (the default)
    ContextLong = 0 ' apparently not required.
     
 
    FTPSuccessBool = FtpGetFile(MyFTPHandleLong, RemoteFileStr, NewFileStr, FailIfExistsBool, FlagsAndAttributesLong, FlagsLong, ContextLong)
 
    MsgBox "FTP Success = " & FTPSuccessBool
 
     ' ************************************
     ' **                                **
     ' **  Finally, close the connection **
     ' **                                **
     ' ************************************
     
 
    SomeInteger = InternetCloseHandle(MyInternetHandleLong)
 
     ' MsgBox SomeInteger
     ' Seems to return "1"
     
 
End Sub

Sub RunNotepad()
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.Run "Notepad"
    Set WshShell = Nothing
End Sub

WshShell.Run "Calc"
WshShell.Run "Explorer"

Sub OpenTxtFileInNotepad()
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.Run "Notepad C:\Phones.txt"
    Set WshShell = Nothing
End Sub

Sub RunDOSCommand()
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.Run ("Command /c Dir >1pt1:")
End Sub

Set myShortcut=WshShell.CreateShortcut(Pathname)

WshShell.TargetPath=ActiveWorkbook.FullName

WshShell.WindowStyle=1

WshShell.HotKey="Ctrl+Alt+W"

WshShell.IconLocation="notepad.exe,0"

WshShell.Description="Wordware Web Site"

strWorkDir=WshShell.SpecialFolders("Desktop")
WshShell.WorkingDirectory=strWorkDir

Sub CreateShortcut()
    '在桌面创建两个快捷方式
    Dim WshShell As Object
    Dim objShortcut As Object
    Set WshShell = CreateObject("WScript.Shell")
    '创建一个Internet快捷方式
    Set objShortcut = _
 WshShell.CreateShortcut(WshShell.SpecialFolders("Desktop") _
& "\Wordware.url")
    objShortcut.TargetPath = "http://www.wordware.com"
    objShortcut.Save
    '创建一个文件快捷方式
    Set objShortcut = _
 WshShell.CreateShortcut(WshShell.SpecialFolders("Desktop") & _
           "\" & ActiveWorkbook.Name & ".lnk")
 
    With objShortcut
        .TargetPath = ActiveWorkbook.FullName
        .WindowStyle = 7
        .Save
    End With
    Set objShortcut = Nothing
    Set WshShell = Nothing
End Sub