Office: (Office 2003) Thumbnails automatisch erstellen

Scorefun · 30. August 2006

\@Sascha: klappt super !

stefacht · 4. September 2006

Hi,

bin erst heute dazu gekommen, den geänderten Code auszuprobieren - aber ich muss sagen, der funktioniert wirklich super! Die Bilder haben jetzt gute Qualität und sind gestochen scharf.

Danke, Sascha!

Ich muss überhaupt mal dem gesamten MOF-Team ein großes Lob aussprechen. Ihr habt mir (und sehr vielen anderen) schon öfters bei Access-Problemen geholfen - ohne euch hätte ich da sicher nicht immer eine (so gute) Lösung gefunden!

Sascha Trowitzsch · 4. September 2006

Danke für die Lorbeeren, Stefacht.
BTW: Bist eigentlich ein Freund des Prepared Piano? *wink.gif*

Ciao, Sascha

User · 28. Juni 2007

Leider führt dieser Code zum Speicherüberlauf nach der Abarbeitung von ca. 10-12 tiffs (Größe durchschnittl. 15 Mb).

Sascha Trowitzsch · 13. Dezember 2008

Richdisch, rischdisch!

Bitte weder den Code aus #15 verwenden, noch den aus #5.
In beiden fehlt der Abbau des Thumbnail-Objekts (lThumb) über Dispose.
Korrigiert hier:
Code:

Public Enum PicFileType
pictypeBMP = 1
pictypeGIF = 2
pictypePNG = 3
pictypeJPG = 4
End Enum

Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type

Private Type EncoderParameter
Guid As UUID
NumberOfValues As Long
type As Long
Value As Long
End Type

Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type

Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus.dll" (ByVal FileName As Long, BITMAP As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, BITMAP As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus.dll" (ByVal BITMAP As Long, hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As UUID, encoderParams As Any) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
Private Declare Function GdipGetImageThumbnail Lib "gdiplus.dll" (ByVal Image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus.dll" (ByVal Image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus.dll" (ByVal Image As Long, Height As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As UUID) As Long

Function ResamplePicFile(SourceFile As String, _
DestFile As String, _
ScalePercentage As Long, _
Optional DestFileType As PicFileType = pictypePNG) As Boolean
Dim tSI As GdiplusStartupInput
Dim lGDIP As Long
Dim lBitmap As Long, lThumb As Long
Dim TEncoder As UUID
Dim TParams As EncoderParameters
Dim sType As String
Dim H As Long, W As Long
Dim ret As Long

Const JPGQuality = 80&

tSI.GdiplusVersion = 1
ret = GdiplusStartup(lGDIP, tSI)
If ret = 0 Then
If GdipCreateBitmapFromFile(StrPtr(SourceFile), lBitmap) = 0 Then
ret = GdipGetImageWidth(lBitmap, W)
ret = GdipGetImageHeight(lBitmap, H)
ret = GdipGetImageThumbnail(lBitmap, (W * ScalePercentage) \ 100, _
(H * ScalePercentage) \ 100, lThumb, 0, 0)
Select Case DestFileType
Case pictypeBMP: sType = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Case pictypeGIF: sType = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Case pictypePNG: sType = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Case pictypeJPG: sType = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
End Select
CLSIDFromString StrPtr(sType), TEncoder
TParams.Count = 0
If DestFileType = pictypeJPG Then
TParams.Count = 1
With TParams.Parameter
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .Guid
.NumberOfValues = 1
.type = 4
.Value = VarPtr(JPGQuality)
End With
End If
ret = GdipSaveImageToFile(lThumb, StrPtr(DestFile), TEncoder, TParams)
ResamplePicFile = (ret = 0)
GdipDisposeImage lThumb
GdipDisposeImage lBitmap
End If
GdiplusShutdown lGDIP
End If

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Sorry für alle, denen der Speicher vollgelaufen ist. *wink.gif*

Ciao, Sascha

Scorefun · 13. Dezember 2008

Ein großes Dankeschön an Sascha !*winner

Office: (Office 2003) Thumbnails automatisch erstellen

Thumbnails automatisch erstellen

Thumbnails automatisch erstellen

Thumbnails automatisch erstellen

Thumbnails automatisch erstellen - Similar Threads - Thumbnails automatisch erstellen

Automatisches Inhaltsverzeichnis mit Leerzeichen

Autofilter bei Zelländerung automatisch aktualisieren – ohne VBA

Power Points zusammenfügen automatisch

Überschneidungen von Zeiten automatisch erkennen

Probleme mit dem automatisches Inhaltsverzeichnis

Änderung Titel Folie 1 für alle weiteren Folien übernehmen

eingehende Emails über bestimmtes Konto automatisch weiterleiten