Skip to main content

AccessTr.neT


Resim Karşılaştırma

Resim Karşılaştırma

#7
Resimleri base64'e çevirmek için kod gerekli. Ayrıca bu işlem için resimlerin dizine aktarılması da gerekli. Tabloya gömülü resmi kodlayamazsınız. Anlamadığınız kodlamayı kullanmadığınız için örnek hazırlamaya gerek yok.
Cevapla
#8
Kod:
Sub TestBase64()
    Dim bytes, b64
    With CreateObject("ADODB.Stream")
    .Open
    .Type = ADODB.adTypeBinary
    .LoadFromFile "c:\temp\TestPic.jpg"
    bytes = .Read
    .Close
    End With
    Debug.Print bytes
    b64 = Base64Encode(bytes)
    Debug.Print vbCrLf + vbCrLf
    Debug.Print b64
    Debug.Print vbCrLf + vbCrLf
    Debug.Print Base64Decode(CStr(b64))        
End Sub

' Decodes a base-64 encoded string (BSTR type).
' 1999 - 2004 Antonin Foller, http://www.motobit.com
' 1.01 - solves problem with Access And 'Compare Database' (InStr)
Function Base64Decode(ByVal base64String)
  'rfc1521
  '1999 Antonin Foller, Motobit Software, http://Motobit.cz
  Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  Dim dataLength, sOut, groupBegin

  'remove white spaces, If any
  base64String = Replace(base64String, vbCrLf, "")
  base64String = Replace(base64String, vbTab, "")
  base64String = Replace(base64String, " ", "")

  'The source must consists from groups with Len of 4 chars
  dataLength = Len(base64String)
  If dataLength Mod 4 <> 0 Then
    Err.Raise 1, "Base64Decode", "Bad Base64 string."
    Exit Function
  End If


  ' Now decode each group:
  For groupBegin = 1 To dataLength Step 4
    Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
    ' Each data group encodes up To 3 actual bytes.
    numDataBytes = 3
    nGroup = 0

    For CharCounter = 0 To 3
      ' Convert each character into 6 bits of data, And add it To
      ' an integer For temporary storage.  If a character is a '=', there
      ' is one fewer data byte.  (There can only be a maximum of 2 '=' In
      ' the whole string.)

      thisChar = Mid(base64String, groupBegin + CharCounter, 1)

      If thisChar = "=" Then
        numDataBytes = numDataBytes - 1
        thisData = 0
      Else
        thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
      End If
      If thisData = -1 Then
        Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
        Exit Function
      End If

      nGroup = 64 * nGroup + thisData
    Next

    'Hex splits the long To 6 groups with 4 bits
    nGroup = Hex(nGroup)

    'Add leading zeros
    nGroup = String(6 - Len(nGroup), "0") & nGroup

    'Convert the 3 byte hex integer (6 chars) To 3 characters
    pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _
      Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _
      Chr(CByte("&H" & Mid(nGroup, 5, 2)))

    'add numDataBytes characters To out string
    sOut = sOut & Left(pOut, numDataBytes)
  Next

  Base64Decode = sOut
End Function

Function Base64Encode(inData)
  'rfc1521
  '2001 Antonin Foller, Motobit Software, http://Motobit.cz
  Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  Dim cOut, sOut, i

  'For each group of 3 bytes
  For i = 1 To Len(inData) Step 3
    Dim nGroup, pOut, sGroup

    'Create one long from this 3 bytes.
    nGroup = &H10000 * Asc(Mid(inData, i, 1)) + _
      &H100 * MyASC(Mid(inData, i + 1, 1)) + MyASC(Mid(inData, i + 2, 1))

    'Oct splits the long To 8 groups with 3 bits
    nGroup = Oct(nGroup)

    'Add leading zeros
    nGroup = String(8 - Len(nGroup), "0") & nGroup

    'Convert To base64
    pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _
      Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _
      Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _
      Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)

    'Add the part To OutPut string
    sOut = sOut + pOut

    'Add a new line For Each 76 chars In dest (76*3/4 = 57)
    'If (I + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf
  Next
  Select Case Len(inData) Mod 3
    Case 1: '8 bit final
      sOut = Left(sOut, Len(sOut) - 2) + "=="
    Case 2: '16 bit final
      sOut = Left(sOut, Len(sOut) - 1) + "="
  End Select
  Base64Encode = sOut
End Function

Function MyASC(OneChar)
  If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function

gibi bir kodlamanın bu iş için kullanılacağının farkındayım. Evet bu kod beni haydi haydi aşar. Aradığım, bu iş için tabloya gömülü bir OLE nin ya da EK'in bir sorgu vasıtası ile convert edilip edilemeyeceği idi. Teşekkürler.
Cevapla
#9
Ekli metin belgesindeki kod, örnek uygulamanızdaki resmin base kodlarıdır. Bu kodları kopyalayıp aşağıdaki siteden dönüştürerek test edebilirsiniz. Bu resim kodunu, Vba kodu kullanmadan sadece sorgu ile dönüştüremezsiniz. Resim farkını bulmak için, iki resme ait kodların ilk 1000 karakterini karşılaştırarak test edilebilir. Benim bahsettiğim mevzu bu idi.

https://codebeautify.org/base64-to-image-converter
.rar ResimBase64.rar (Dosya Boyutu: 749,03 KB | İndirme Sayısı: 3)
Cevapla
#10
Ekli örnek, tablodaki Bit İşlem Resmini istenilen dizine aktarılması için örnektir. Resim farkını bulmak için resmin base64 kodlamasını yapar ve karşılaştırır. Resim farkından ziyade resmi dizine aktarmak için kullanılabilir. Kodlamaya göre resim temp içerisine aktarılıyor.
.rar Resim_Aktar.rar (Dosya Boyutu: 1,26 MB | İndirme Sayısı: 7)
Cevapla
#11
(20/11/2018, 16:48)ozanakkaya yazdı: Ekli örnek, tablodaki Bit İşlem Resmini istenilen dizine aktarılması için örnektir. Resim farkını bulmak için resmin base64 kodlamasını yapar ve karşılaştırır. Resim farkından ziyade resmi dizine aktarmak için kullanılabilir. Kodlamaya göre resim temp içerisine aktarılıyor.

Tşk.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task