Ich verwende hier hin und wieder gern Bilder in den Posts und habe dazu die Umwandlung der Bilder automatisiert.
Wenns jemand brauchen kann, bitte sehr:
Option Explicit
Private Const c_iHEIGHTDIMENSION As Integer = 180
Private Const c_iWIDTHDIMENSION As Integer = 364
Private Const c_sFILEEXTENSION As String = "PNG"
Private sPath As String
Private sFile As String
Private vDimensions() As Variant
Private vFileProperties As Variant 'Array: 0=Dateiname, 1=Height, 2=width
Sub CreateBase64StringFromLastScreenshot()
'*** Temporärer Ordner für Screenshot für Windows 11
sPath = Environ("LOCALAPPDATA") & "\Packages\MicrosoftWindows.Client.CBS_cw5n1h2txyewy\TempState\ScreenClip\"
'*** Datei finden
vFileProperties = GetLastFileFromClipboard()
sFile = vFileProperties(0)
If Not sFile = vbNullString Then
'*** Output from clipboard
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText "<p> <img src=""data:image/jpeg;base64," & encodeBase64(readBytes(sFile)) & """ Height=""" & vFileProperties(1) & "px"" width=""" & vFileProperties(2) & "px""/></p>"
.PutInClipboard
End With
End If
End Sub
Function readBytes(ByVal sFile As String) As Byte()
With CreateObject("ADODB.Stream")
.Open
.Type = 1 'adBinary
.LoadFromFile sFile
readBytes = .Read()
End With
End Function
Function encodeBase64(bytes)
With CreateObject("Microsoft.XMLDOM")
With .createElement("tmp")
.DataType = "bin.base64"
.nodeTypedValue = bytes
encodeBase64 = Replace(Replace(.Text, vbCr, ""), vbLf, "")
End With
End With
End Function
Function GetLastFileFromClipboard() As Variant
Dim rs As Object 'ADODB.Recordset
Dim fso As Object 'Scripting.FileSystemObject
Dim fil As Object 'Scripting.File
'*** Recordset erzeugen
Set rs = CreateObject("ADODB.Recordset")
rs.Fields.Append "Filename", 129, 255
rs.Fields.Append "DateCreated", 5
rs.Fields.Append "Height", 3
rs.Fields.Append "Width", 3
rs.Open
Set fso = CreateObject("Scripting.FileSystemObject")
With fso
With .GetFolder(sPath)
For Each fil In .Files
If UCase$(fso.GetExtensionName(fil)) = c_sFILEEXTENSION Then
vDimensions() = GetImageDimensions(fil.Path)
'*** Prüfen, ob nicht Vorschaubild (364*180)
If Not vDimensions(0) = c_iHEIGHTDIMENSION And Not vDimensions(1) = c_iWIDTHDIMENSION Then
rs.addnew Array(0, 1, 2, 3), Array(fil.Path, fil.DateCreated, vDimensions(0), vDimensions(1)): rs.Update
End If
End If
Next
End With
End With
If Not rs.RecordCount = 0 Then
'*** Recordset sortieren
rs.movefirst
rs.Sort = rs.Fields(1).Name & " DESC," & rs.Fields(2).Name & " DESC"
'*** Dateinamen zurückgeben
GetLastFileFromClipboard = Array(RTrim(rs.Fields(0).Value), rs.Fields(2).Value, rs.Fields(3).Value)
rs.Close
Else
GetLastFileFromClipboard = vbNullString
End If
End Function
Function GetImageDimensions(ByVal sImageFile As String) As Variant
Static oWIA As ImageFile
If oWIA Is Nothing Then: Set oWIA = CreateObject("WIA.ImageFile")
With oWIA
.LoadFile sImageFile
GetImageDimensions = Array(oWIA.Height, oWIA.Width)
End With
End Function
Die Funktionen readByte(), encodeBase64(), sowie GetImageDimension() sind zwar leicht abgewandlet aber im Grunde im Netz zu finden.
Ob sPath auf allen Rechner gleichen Ergebnis führt, kann Ich nicht sagen. Bei ner handvoll Rechner gabs keinerlei Probleme.
Ablauf:
WinTaste+Shift+S drücken, dann die Sub CreateBase64StringFromLastScreenshot() ausführen.
Hier im Editor auf drücken, per STG+V den String einfügen und wieder drücken.
Hinweis:
Es werden 2PNG-Files sowie ein JSON File in dem Ordner abgelegt.
Das letzte PNG-File sollte das gewünscht Bild sein. Wenn die ABmessungen allerdings 180*364 sind, ist es das Vorschaubild.
Deshalb werden diese Abmessungen ignoriert und das nächste Bild genommen.
Verbesserungsvorschläge sind willkommen.
|