title image


Smiley Re: Kontakabzug in Word
Hi,



falls Du eine Windows-Version verwendest, deren Shell die "Miniaturansicht" (z.B. im Explorer) unterstützt, d.h. Win98/Me/2000/XP/2003, kannst Du den Kontaktabzug recht einfach aus den Shell-Thumbnails - ganz ohne Zusatzprogramme - erzeugen. Thumbnails gibt es standardmäßig für Bilder und alle anderen Dateitypen, die Miniaturansicht speichern können (Powerpoint, Word etc.).



Einziges Problem in VBA ist die Verwendung der erfoderlichen Inferfaces, wozu man geeigente Typenbibliotheken braucht. Folgender Code verwendet die Shell-TLBs von Brad Martinez (Verweise vor dem Kompilieren setzen) und erzeugt eine Tabelle aus den Thumbnails (wie im Explorer) von Datein eines Ordners.

Option Explicit



'================================================================================

' List_FileThumbnails() Wolfram, 2.2.2003

'

' Vorschaugrafik (wie in Explorer angezeigt) von Dateien eines Ordners

' in ein Word-Dokument einfügen, für WD2000 und höher.

'

' benötigt Brad Martinez' Type-Libraries ISHF_Ex.tlb und IExtractImage2.tlb

'================================================================================



Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long



Private Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long



Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)



Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long



Private Declare Function CloseClipboard Lib "user32" () As Long



Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long



Private Declare Function EmptyClipboard Lib "user32" () As Long



Private Const CF_BITMAP = 2





Sub List_FileThumbnails()



Dim sPath As String, sFile As String, Filter As String

Dim hwnd As Long, HBmp As Long

Const AnzahlSpalten = 4 ' passend zur Bildgröße IMGSIZE



' Ordner wählen

On Error Resume Next

With CreateObject("Shell.Application")

With .BrowseForFolder(0&, "Bitte Ordner wählen...", 7&, 0)

sPath = .self.Path

If Len(sPath) = 0 Then Exit Sub

End With

End With



' Dateiliste holen

sFile = Dir(sPath & "\", vbArchive + vbReadOnly)

If Len(sFile) Then



' wenn nicht leer, Tabelle in neues Dokument

Dim oDoc As Document, r As Long, c As Long, i As Long, pic As Picture

Set oDoc = Documents.Add

oDoc.Tables.Add oDoc.Range(0, 0), 1, AnzahlSpalten

' hwnd von oDoc (nur für MDI-Interface von WD2000 und höher!)

hwnd = FindWindow("OpusApp", oDoc.ActiveWindow.Caption & " - " & Application.Caption)



' IShellFolder des gewählten Ornders setzen

Dim isfFolder As ishellfolderex_tlb.IShellFolder

Set isfFolder = Get_isfFolder(hwnd, sPath)

If isfFolder Is Nothing Then Exit Sub



' Schleife über alle Dateien

While Len(sFile)

' hole Thumnail Bitmap

HBmp = ExtractImage(hwnd, isfFolder, sFile)

' Thumbnail und Filename in Zelle (Row, Column) einfügen

If i And ((i Mod AnzahlSpalten) = 0) Then oDoc.Tables(1).Rows.Add

With oDoc.Tables(1).Cell(r + 1, c + 1)

' wenn Thumbnail vorhanden

If HBmp Then

' Bitmap als InlineShape über Clipboard einfügen

OpenClipboard hwnd: EmptyClipboard

SetClipboardData CF_BITMAP, HBmp: CloseClipboard

.Range.Paste

End If

.Range.InsertAfter vbCrLf & sFile

.VerticalAlignment = wdCellAlignVerticalBottom

.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter

End With

i = i + 1: c = i Mod AnzahlSpalten: r = i \ AnzahlSpalten

sFile = Dir

Wend ' sFile Loop



End If ' Dateien vorhanden

Set isfFolder = Nothing



End Sub



Private Function ExtractImage(hWndDlg As Long, isfFolder As ishellfolderex_tlb.IShellFolder, sFile As String) As Long



Const MAX_PATH = 260, IMGSIZE = 100 ' Bitmap x-y-Pixel-Size



Static IID_IExtractImage As ishellfolderex_tlb.GUID

Dim IEI As IExtractImage2Lib.IExtractImage, sz As IExtractImage2Lib.SIZE

Dim pidlFile As Long, pchEaten As Long, sPath As String * MAX_PATH

Dim lpFlags As IEIFlags, lpPriority As Long, HBmp As Long



If Not IID_IExtractImage Then

With IID_IExtractImage ' IExtractImage Interface ID

.Data1 = &HBB2E617C

.Data2 = &H920

.Data3 = &H11D1

.Data4(0) = &H9A: .Data4(1) = &HB: .Data4(2) = &H0: .Data4(3) = &HC0

.Data4(4) = &H4F: .Data4(5) = &HC2: .Data4(6) = &HD6: .Data4(7) = &HC1

End With

End If



' get sFile's relative pidl to isfFolder

If 0 = isfFolder.ParseDisplayName(hWndDlg, 0, StrConv(sFile, vbUnicode), pchEaten, pidlFile, 0) Then

' get IExtractImage Interface IEI if available

If 0 = isfFolder.GetUIObjectOf(hWndDlg, 1, pidlFile, IID_IExtractImage, 0, IEI) Then

' extract image

sz.cx = IMGSIZE: sz.cy = IMGSIZE ' image size

lpFlags = IEIFLAG_OFFLINE

' GetLocation must be called before extracting image

If 0 = IEI.GetLocation(sPath, MAX_PATH, lpPriority, sz, 32, lpFlags) Then IEI.Extract HBmp

End If ' GetUIObjectOf

CoTaskMemFree pidlFile

End If ' relative pidl



ExtractImage = HBmp



End Function





Private Function Get_isfFolder(ByVal hWndDlg As Long, ByVal sPath As String) As IShellFolder

' get IShellFolder for sPath



Static isfDesktop As ishellfolderex_tlb.IShellFolder

Dim isfFolder As ishellfolderex_tlb.IShellFolder

Static IID_IShellFolder As ishellfolderex_tlb.GUID

Dim pidlFile As Long, pchEaten As Long



If Not IID_IShellFolder Then

With IID_IShellFolder ' IShellFolder Interface ID

.Data1 = &H214E6

.Data4(0) = &HC0: .Data4(7) = &H46

End With

End If



If isfDesktop Is Nothing Then SHGetDesktopFolder isfDesktop



If 0 = isfDesktop.ParseDisplayName(hWndDlg, 0, StrConv(sPath, vbUnicode), pchEaten, pidlFile, 0) Then

isfDesktop.BindToObject pidlFile, 0, IID_IShellFolder, isfFolder

If pidlFile Then CoTaskMemFree pidlFile

End If



Set Get_isfFolder = isfFolder



End FunctionWelche Dateien, Thumbnail-Größe und Dok-Layout kannst Du im Code nach Wunsch anpassen.



TLBs: ISHF_Ex.tlb, IExtractImage2.tlb



Grüße

Wolfram

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: