Új hozzászólás Aktív témák

• #37778 lcdtv tag lcdtv #37777

  Új Válasz 2018-04-12 18:26:45 #37778

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  lcdtv

  tag

  válasz lcdtv #37777 üzenetére

  Válaszolok is ha valakinek szüksége lenne rá.
  Option Explicit
Public Enum DownloadFileDisposition
OverwriteKill = 0
OverwriteRecycle = 1
DoNotOverwrite = 2
PromptUser = 3
End Enum

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows API functions, constants,and types.
' Used for RecycleFile.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" _
Alias "PathIsNetworkPathA" ( _
ByVal pszPath As String) As Long

Private Declare Function GetSystemDirectory Lib "kernel32" _
Alias "GetSystemDirectoryA" ( _
ByVal lpBuffer As String, _
ByVal nSize As Long) As Long

Private Declare Function SHEmptyRecycleBin _
Lib "shell32" Alias "SHEmptyRecycleBinA" _
(ByVal hwnd As Long, _
ByVal pszRootPath As String, _
ByVal dwFlags As Long) As Long

Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_NOCONFIRMATION = &H10
Private Const MAX_PATH As Long = 260

Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type

'''''''''''''''''''''''''''
' Download API function.
''''''''''''''''''''''''''''''''''''''
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DownloadFile
' This downloads a file from a URL to a local filename.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function DownloadFile(UrlFileName As String, _
DestinationFileName As String, _
Overwrite As DownloadFileDisposition, _
ErrorText As String) As Boolean

Dim Disp As DownloadFileDisposition
Dim Res As VbMsgBoxResult
Dim B As Boolean
Dim S As String
Dim L As Long

ErrorText = vbNullString

If Dir(DestinationFileName, vbNormal) <> vbNullString Then
Select Case Overwrite
Case OverwriteKill
On Error Resume Next
Err.Clear
Kill DestinationFileName
If Err.Number <> 0 Then
ErrorText = "Error Kill'ing file '" & DestinationFileName & "'." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If

Case OverwriteRecycle
On Error Resume Next
Err.Clear
B = RecycleFileOrFolder(DestinationFileName)
If B = False Then
ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If

Case DoNotOverwrite
DownloadFile = False
ErrorText = "File '" & DestinationFileName & "' exists and disposition is set to DoNotOverwrite."
Exit Function

'Case PromptUser
Case Else
S = "The destination file '" & DestinationFileName & "' already exists." & vbCrLf & _
"Do you want to overwrite the existing file?"
Res = MsgBox(S, vbYesNo, "Download File")
If Res = vbNo Then
ErrorText = "User selected not to overwrite existing file."
DownloadFile = False
Exit Function
End If
B = RecycleFileOrFolder(DestinationFileName)
If B = False Then
ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If
End Select
End If

L = URLDownloadToFile(0&, UrlFileName, DestinationFileName, 0&, 0&)
If L = 0 Then
DownloadFile = True
Else
ErrorText = "Buffer length invalid or not enough memory."
DownloadFile = False
End If

End Function

Private Function RecycleFileOrFolder(FileSpec As String) As Boolean

Dim FileOperation As SHFILEOPSTRUCT
Dim lReturn As Long

If (Dir(FileSpec, vbNormal) = vbNullString) And _
(Dir(FileSpec, vbDirectory) = vbNullString) Then
RecycleFileOrFolder = True
Exit Function
End If

With FileOperation
.wFunc = FO_DELETE
.pFrom = FileSpec
.fFlags = FOF_ALLOWUNDO
' Or
.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
End With

lReturn = SHFileOperation(FileOperation)
If lReturn = 0 Then
RecycleFileOrFolder = True
Else
RecycleFileOrFolder = False
End If
End Function

Sub example()

Dim URL As String
Dim LocalFileName As String
Dim B As Boolean
Dim ErrorText As String
Dim c As Range

For Each c In Columns("K:L").SpecialCells(xlCellTypeConstants, 23)
URL = c
LocalFileName = "C:\temp\" & Evaluate("TRIM(RIGHT(SUBSTITUTE(""" & c & """,""/"",REPT("" "",1000)),1000))")
B = DownloadFile(UrlFileName:=URL, _
DestinationFileName:=LocalFileName, _
Overwrite:=PromptUser, _
ErrorText:=ErrorText)
If B = True Then
Debug.Print "Download successful"
Else
Debug.Print "Download unsuccessful: " & ErrorText
End If
Next c

End Sub

Új hozzászólás Aktív témák