تحويل ملف لى base64

[Mohameddd200300]

سلام عليكم ورحمة الله له لديكم ملف او كود vba  لتحويل ملف او صورة ال تشفير base64  احتاجه  ضروري جدا وشكرا لكم 

[أبو إبراهيم الغامدي]

9 ساعات مضت, Mohameddd200300 said:

سلام عليكم ورحمة الله له لديكم ملف او كود vba  لتحويل ملف او صورة ال تشفير base64  احتاجه  ضروري جدا وشكرا لكم

وعليكم السلام ورحمة الله بركاته

الإجرائان التاليان للتشفير، وفك التشفير

Sub EncodeBinaryFileToBase64(BinaryFileName As String, Base64FileName As String)

   Dim XML, Node, InputFile, OutputFile, XPath
   Dim FSO, Output, InStream, ReadBytes, Base64Encode
   XPath = CurrentProject.Path & "\"
   InputFile = XPath & BinaryFileName
   OutputFile = XPath & Base64FileName
   
   Set InStream = CreateObject("ADODB.Stream")
   InStream.Open
   InStream.Type = 1 'TypeBinary
   InStream.LoadFromFile (InputFile)
   ReadBytes = InStream.Read()
   InStream.Close
   
   Set XML = CreateObject("Msxml2.DOMDocument")
   Set Node = XML.createElement("base64")
   Node.DataType = "bin.base64"
   Node.nodeTypedValue = ReadBytes
   Base64Encode = Node.Text
   
   Set FSO = CreateObject("Scripting.Filesystemobject")
   Set Output = FSO.CreateTextFile(OutputFile, 1)
   Output.Write Base64Encode
   Output.Close
End Sub


Sub DecodeBase64ToBinaryFile(Base64FileName As String, BinaryFileName As String)
   
   Dim InputFile, OutputFile, XPath, Contents
   Dim FSO, XML, Node, BinaryStream, XInput
   
   XPath = CurrentProject.Path & "\"
   
   InputFile = XPath & Base64FileName
   OutputFile = XPath & BinaryFileName
   
   Set FSO = CreateObject("Scripting.Filesystemobject")
   
   Set XInput = FSO.OpenTextFile(InputFile, 1)
   Contents = XInput.ReadAll()
   XInput.Close
     
   Set XML = CreateObject("Msxml2.DOMDocument")
   Set Node = XML.createElement("base64")
   Node.DataType = "bin.base64"
   Node.Text = Contents
   
   Set BinaryStream = CreateObject("ADODB.Stream")
   BinaryStream.Type = 1 'adTypeBinary
   BinaryStream.Open
   BinaryStream.Write Node.nodeTypedValue
   BinaryStream.SaveToFile OutputFile
End Sub

 

Base64.accdb

[Mohameddd200300]

تسلم اخوي @أبو إبراهيم الغامدي 

لاكن يبدو ان التشفير ناقص انا احتاك ان اشفه منشان ارسله من خلال api  من خلال موقع https://user.ultramsg.com/ 

وهناك طريقتنا  لكي ترسل شي من جهازك الاولا ان تكون محملة من موقع وتلصق الرابط  والثاني ان تحويل الملفات لـ Base64  وترسله يا ما من الموقع او منخلال ال api   لقيت موقع  مثل https://www.browserling.com/tools/file-to-base64   تحويل الملفات لـ Base64 ويبله الموقع  .

ليش قلت الكود التشفير ناقص لما اشفر الملف من المةاقع واحولة الصقه في اكسس يقول النص طويل جدا  اما في اكسس التشفير الي ينتجه اقصر منه ويقبل النسخ والصق في مربع النص فهمت علي الله يسلمك فنا محتار بطريقتان حت جالس استخدم الذكاء الاصطناعي من غي رفغايدة ولدلي اكود لتحويل وبرضه مش ضابطه  وهذا رابط موضعهم من الموقع الي ارسل منه  باكثر من لغة https://blog.ultramsg.com/ar/أرسل-واتس-اب-صور-وثائق-باستخدام-base64/#mthal_larsal_mstnd_WhatsApp_pdf_k_Base64_bastkhdam_vbnet

[دروب مبرمج]

تفضل هذا الكود للتشفير و فك التشفير

لكن في البداية لابد من اضافة مكتبة XML من الاصدار الثاني و اعلا

Option Explicit
Private Const clOneMask = 16515072
Private Const clTwoMask = 258048
Private Const clThreeMask = 4032
Private Const clFourMask = 63

Private Const clHighMask = 16711680
Private Const clMidMask = 65280
Private Const clLowMask = 255

Private Const cl2Exp18 = 262144
Private Const cl2Exp12 = 4096
Private Const cl2Exp6 = 64
Private Const cl2Exp8 = 256
Private Const cl2Exp16 = 65536

Public Function Encode64(sString As String) As String

    Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte
    Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, lOutSize As Long

    For lTemp = 0 To 63
        Select Case lTemp
            Case 0 To 25
                bTrans(lTemp) = 65 + lTemp
            Case 26 To 51
                bTrans(lTemp) = 71 + lTemp
            Case 52 To 61
                bTrans(lTemp) = lTemp - 4
            Case 62
                bTrans(lTemp) = 43
            Case 63
                bTrans(lTemp) = 47
        End Select
    Next lTemp

    For lTemp = 0 To 255
        lPowers8(lTemp) = lTemp * cl2Exp8
        lPowers16(lTemp) = lTemp * cl2Exp16
    Next lTemp

    iPad = Len(sString) Mod 3
    If iPad Then
        iPad = 3 - iPad
        sString = sString & String(iPad, Chr(0))
    End If

    bIn = StrConv(sString, vbFromUnicode)
    lLen = ((UBound(bIn) + 1) \ 3) * 4
    lTemp = lLen \ 72
    lOutSize = ((lTemp * 2) + lLen) - 1
    ReDim bOut(lOutSize)

    lLen = 0

    For lChar = LBound(bIn) To UBound(bIn) Step 3
        lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2)
        lTemp = lTrip And clOneMask
        bOut(lPos) = bTrans(lTemp \ cl2Exp18)
        lTemp = lTrip And clTwoMask
        bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12)
        lTemp = lTrip And clThreeMask
        bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6)
        bOut(lPos + 3) = bTrans(lTrip And clFourMask)
        If lLen = 68 Then
            bOut(lPos + 4) = 13
            bOut(lPos + 5) = 10
            lLen = 0
            lPos = lPos + 6
        Else
            lLen = lLen + 4
            lPos = lPos + 4
        End If
    Next lChar

    If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2

    If iPad = 1 Then
        bOut(lOutSize) = 61
    ElseIf iPad = 2 Then
        bOut(lOutSize) = 61
        bOut(lOutSize - 1) = 61
    End If

    Encode64 = StrConv(bOut, vbUnicode)

End Function

Public Function Decode64(sString As String) As String

    Dim bOut() As Byte, bIn() As Byte, bTrans(255) As Byte, lPowers6(63) As Long, lPowers12(63) As Long
    Dim lPowers18(63) As Long, lQuad As Long, iPad As Integer, lChar As Long, lPos As Long, sOut As String
    Dim lTemp As Long

    sString = Replace(sString, vbCr, vbNullString)
    sString = Replace(sString, vbLf, vbNullString)

    lTemp = Len(sString) Mod 4
    If lTemp Then
        Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.")
    End If

    If InStrRev(sString, "==") Then
        iPad = 2
    ElseIf InStrRev(sString, "=") Then
        iPad = 1
    End If

    For lTemp = 0 To 255
        Select Case lTemp
            Case 65 To 90
                bTrans(lTemp) = lTemp - 65
            Case 97 To 122
                bTrans(lTemp) = lTemp - 71
            Case 48 To 57
                bTrans(lTemp) = lTemp + 4
            Case 43
                bTrans(lTemp) = 62
            Case 47
                bTrans(lTemp) = 63
        End Select
    Next lTemp

    For lTemp = 0 To 63
        lPowers6(lTemp) = lTemp * cl2Exp6
        lPowers12(lTemp) = lTemp * cl2Exp12
        lPowers18(lTemp) = lTemp * cl2Exp18
    Next lTemp

    bIn = StrConv(sString, vbFromUnicode)
    ReDim bOut((((UBound(bIn) + 1) \ 4) * 3) - 1)

    For lChar = 0 To UBound(bIn) Step 4
        lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lChar + 1))) + _
                lPowers6(bTrans(bIn(lChar + 2))) + bTrans(bIn(lChar + 3))
        lTemp = lQuad And clHighMask
        bOut(lPos) = lTemp \ cl2Exp16
        lTemp = lQuad And clMidMask
        bOut(lPos + 1) = lTemp \ cl2Exp8
        bOut(lPos + 2) = lQuad And clLowMask
        lPos = lPos + 3
    Next lChar

    sOut = StrConv(bOut, vbUnicode)
    If iPad Then sOut = Left$(sOut, Len(sOut) - iPad)
    Decode64 = sOut

End Function

 

[Mohameddd200300]

 سلام عليكم  اخوي # دروب مبرمج  هذا الكود يقوم بتشفير النص فقط هل يمكن تشفير ملف PDF   واذا كان نعم كيف اقوم بتحديد مسار  ملف الي المفروض يشفره  واين يضهر النص المشفر 

وشكرا لك