26.09.2012

Internet - Dateien - Download - Hyperlink setzen

Frage: In einem Tabellenblatt habe ich eine Liste mit Adressen von Bildern im Internet. Diese möchte ich auf meine Festplatte kopieren und eine Spalte neben der Adresse als Hyperlink einfügen. Wie geht das?

Hier noch eine Beispieldatei: Internet - Picture - Download

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Private Declare Function DeleteUrlCacheEntry Lib "wininet" Alias _
    "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" _
    Alias "PathFileExistsA" (ByVal pszPath As String) As Long
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
Const strPath As String = "C:\PicDown\"
Public Sub Main()
    Dim wksSheet As Worksheet
    Dim lngLastRow As Long
    Dim strFile As String
    Dim lngResult As Long
    Dim strURL As String
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    MakeSureDirectoryPathExists strPath
    If IsFilePath(strPath) Then
        On Error Resume Next
        Kill strPath & "*.*"
        On Error GoTo Fin
    End If
    Set wksSheet = ThisWorkbook.Worksheets("Sheet1")
    With wksSheet
        lngLastRow = IIf(IsEmpty(.Range("B" & .Rows.Count)), _
            .Range("B" & .Rows.Count).End(xlUp).Row, .Rows.Count)
        .Range(.Cells(1, 3), .Cells(lngLastRow, 3)).Clear
        For lngLastRow = 1 To lngLastRow
            strURL = .Cells(lngLastRow, 2).Text
            strFile = strPath & lngLastRow & "_" & _
                Mid(strURL, InStrRev(strURL, "/") + 1)
            Call DeleteUrlCacheEntry(strURL)
            lngResult = URLDownloadToFile(0, strURL, strFile, 0, 0)
            If ExistFile(strFile) = True Then
                If FileLen(strFile) > 1000 Then
                    .Cells(lngLastRow, 3).Value = strFile
                    .Cells(lngLastRow, 3).Hyperlinks.Add _
                        Anchor:=.Cells(lngLastRow, 3), _
                        Address:=strFile
                Else
                    .Cells(lngLastRow, 3).Value = "???"
                End If
            Else
                .Cells(lngLastRow, 3).Value = "No file"
            End If
        Next
    End With
Fin:
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function IsFilePath(strPath As String) As Boolean
    IsFilePath = CBool(PathFileExists(strPath))
End Function
Private Function ExistFile(Pfad As String) As Boolean
    On Error Resume Next
    ExistFile = Not CBool(GetAttr(Pfad) And (vbVolume))
    On Error GoTo 0
End Function

01.09.2012

MS-Project -> Excel!

Frage: Aus MS-Project sollen Daten nach Excel eingelesen werden. Ziel ist es nun, da in dem Projekt die einzelnen Tasks ständig aktualisiert werden, bestimmte Daten aus dem Projekt in Excel unter Abgleich der eindeutigen ID einzufügen bzw. aktuell zu halten. Die ID steht in Excel im ersten Tabellenblatt in Spalte B. Bei Übereinstimmung soll der Wert aus Project in Spalte M eingetragen werden. Wie geht das?

Hier mal der prinzipielle Zugriff auf Project:

Option Explicit
Public Sub Main()
    Dim objMSProject As Object
    Dim intCount As Integer
    Set objMSProject = GetObject(PathName:="C:\Temp\Test.mpp")
    For intCount = 1 To objMSProject.Resources.Count
        Debug.Print objMSProject.Resources.Item(intCount).Name
        Debug.Print objMSProject.Resources.Item(intCount).BaselineWork
        Debug.Print objMSProject.Resources.Item(intCount).BaselineCost
    Next intCount
    Set objMSProject = Nothing
End Sub
Und hier der Code für die ID in Spalte B:
Option Explicit
Public Sub Main()
    Dim objMSProject As Object
    Dim intCount As Integer
    Dim lngLastRow As Long
    On Error GoTo Fin
    With Tabelle1
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 2)), _
            .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
    End With
    Set objMSProject = GetObject("C:\Temp\Test.mpp")
    For lngLastRow = 2 To lngLastRow
        For intCount = 1 To objMSProject.Tasks.Count
            With objMSProject.Tasks.Item(intCount)
                If Tabelle1.Cells(lngLastRow, 2).Value = .Name Then
                    Tabelle1.Cells(lngLastRow, 13).Value = .Start
                End If
            End With
        Next intCount
    Next lngLastRow
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
    Set objMSProject = Nothing
End Sub

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...