vielleicht reicht es auch so...
08.11.2009 17:59:53
Tino
Hallo,
getestet unter Office 2007 und Win- Vista.
Pfad wo Outlook die Anlage abspeichert anpassen.
Eventuell noch die max Anzahl vorkommenter Anlagen anpassen (100 sollten aber reichen)
Nachteil die Anlage muss zuvor einmal offen gewesen sein oder die Anlage im gleichen Ordner speichern,
eine Lösung die Anlage direkt zu öffnen habe ich noch nicht gefunden.
kommt als Code in Modul1
Option Explicit
Sub Schaltfläche1_KlickenSieAuf()
Dim strPath$, strFile$
Dim MeArLink() As String, ArAnlage() As String, i As Integer
Dim LMaxRow As Long
Dim A As Long, AA As Long
'hier die maximale Anzahl Anlagen eintragen die vorkommen kann
Const MaxAnlagen As Long = 100
'Hier den Pfad anpassen wo Outlook die Anlage ablegt
Const OulookTempFilePfad As String = "C:\Users\Tino\AppData\Local\Microsoft\Windows\Temporary Internet Files\Content.Outlook\ERC2OUP5\"
strPath = fncGetFolder(, , "E:\1 Forum\Mail Test") 'Ordnerauswahl
If strPath = "" Then Exit Sub
With Sheets("Tabelle1")
'Bereich leer machen für neue Daten
LMaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If LMaxRow > 2 Then .Range(.Range("A3"), .Cells(LMaxRow, MaxAnlagen)).Clear
'Pfad mit \ am ende
strPath = IIf(Right$(strPath, 1) = "\", strPath, strPath & "\")
'Daten aus Ordner sammeln
strFile = Dir$(strPath & "*.msg")
Do While strFile <> ""
Redim Preserve MeArLink(1 To MaxAnlagen, i)
MeArLink(1, i) = strFile
i = i + 1
strFile = Dir$()
Loop
If i > 0 Then
For i = 0 To i - 1
LeseMsG strPath & MeArLink(1, i), ArAnlage()
MeArLink(1, i) = "=HYPERLINK(""" & strPath & MeArLink(1, i) & """;""" & MeArLink(1, i) & """)"
If IsArray(ArAnlage) Then
AA = 1
For A = Lbound(ArAnlage) To Ubound(ArAnlage)
If Dir(OulookTempFilePfad & ArAnlage(A), vbNormal) <> "" Then
AA = AA + 1
MeArLink(AA, i) = "=HYPERLINK(""" & OulookTempFilePfad & ArAnlage(A) & """;""" & ArAnlage(A) & """)"
End If
Next A
Erase ArAnlage
End If
Next i
'Hyperlink erstellen (Formel)
With .Range("A3").Resize(Ubound(MeArLink, 2) + 1, MaxAnlagen)
.FormulaLocal = Application.Transpose(MeArLink)
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
.EntireColumn.AutoFit
End With
End If
End With
End Sub
Sub LeseMsG(strMSG_File As String, ArAnlage() As String)
Dim F As Integer, sInhalt As String
Dim objRegEx As Object, oMatch As Object
Dim i As Integer, ii As Integer
Dim meArExt
'Dateifilter anpassen
meArExt = Split(".xls;.doc;.pdf;.ppt;.pps", ";")
If Dir$(strMSG_File, vbNormal) <> "" Then
Set objRegEx = CreateObject("VBScript.RegExp")
F = FreeFile
Open strMSG_File For Binary As #F
sInhalt = Space$(LOF(F))
Get #F, , sInhalt
Close
With objRegEx
.MultiLine = True
.Global = True
.IgnoreCase = True
For ii = Lbound(meArExt) To Ubound(meArExt)
.Pattern = "[a-zA-ZäöüßÄÖÜ ]{1,255}" & meArExt(ii)
For Each oMatch In .Execute(sInhalt)
If oMatch Like "*" & meArExt(ii) Then
Redim Preserve ArAnlage(i)
ArAnlage(i) = Trim$(oMatch.Value)
i = i + 1
End If
Next
Next ii
End With
Set objRegEx = Nothing
End If
End Sub
kommt als Code in Modul2
Option Explicit
Private Declare Function MoveWindow Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" ( _
ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
ByVal lpStr1 As String, _
ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
ByVal pList As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassname As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
Private Type InfoT
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Enum BIF_Flag
BIF_RETURNONLYFSDIRS = &H1
BIF_DONTGOBELOWDOMAIN = &H2
BIF_STATUSTEXT = &H4
BIF_RETURNFSANCESTORS = &H8
BIF_EDITBOX = &H10
BIF_VALIDATE = &H20
BIF_NEWDIALOGSTYLE = &H40
BIF_BROWSEINCLUDEURLS = &H80
BIF_BROWSEFORCOMPUTER = &H1000
BIF_BROWSEFORPRINTER = &H2000
BIF_BROWSEINCLUDEFILES = &H4000
BIF_SHAREABLE = &H8000
End Enum
Private Const SM_CXFULLSCREEN = &H10
Private Const SM_CYFULLSCREEN = &H11
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = &H1
Private s_BrowseInitDir As String
Private Function BrowseCallback( _
ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
If uMsg = BFFM_INITIALIZED Then
Call SendMessage(hwnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir)
Call CenterDialog(hwnd)
End If
BrowseCallback = 0
End Function
Private Function FuncCallback(ByVal nParam As Long) As Long
FuncCallback = nParam
End Function
Private Sub CenterDialog(ByVal hwnd As Long)
Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
Dim DlgWidth As Integer, DlgHeight As Integer
GetWindowRect hwnd, WinRect
DlgWidth = WinRect.Right - WinRect.Left
DlgHeight = WinRect.Bottom - WinRect.Top
ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
(ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub
Public Function fncGetFolder( _
Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
Optional ByVal lFlag As BIF_Flag = BIF_RETURNONLYFSDIRS, _
Optional ByVal sPath As String = "C:\") As String
Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
s_BrowseInitDir = sPath
With xl
.hwnd = FindWindow("XLMAIN", vbNullString)
.Root = 0
.Title = lstrcat(sMsg, "")
.Flags = lFlag
.FName = FuncCallback(AddressOf BrowseCallback)
End With
IDList = SHBrowseForFolder(xl)
If IDList <> 0 Then
FolderName = Space(256)
RVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim$(FolderName)
FolderName = Left$(FolderName, Len(FolderName) - 1)
End If
fncGetFolder = FolderName
End Function
Gruß Tino