Thema Datum  Von Nutzer Rating
Antwort
Rot ab Win10: Letztes Bild als BASE64-String
07.03.2022 16:25:55 Mase
NotSolved

Ansicht des Beitrags:
Von:
Mase
Datum:
07.03.2022 16:25:55
Views:
603
Rating: Antwort:
  Ja
Thema:
ab Win10: Letztes Bild als BASE64-String

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.

 

 

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot ab Win10: Letztes Bild als BASE64-String
07.03.2022 16:25:55 Mase
NotSolved