AccessTr.neTMicrosoft AccessAccess Örnekleri ve Uygulamaları

EAN8, EAN13 ve EAN 128 Barkodlar hepsi aynı çalışmada...

1 2 3 4 5 6 7 8 9
20/08/2019, 10:56

ates2014

Sayın berdus,
Dim n, hsp1, hsp2, sonuc As Integer
bu şekilde ekledim,
ama sonuç olarak yukarıda yazdığım gibi 8 rakamını veriyor.?
20/08/2019, 11:00

berduş

dediğim gibi emin değilim ama @ozanakkaya hocamın yazdığı kod kontrol hanesini yani 13. basamağı hesaplama kodu olabilir
isterseniz 13 haneli bir kodun 12 hanesini girerek sonucun 13. basamağa eşit olup olmadığını deneyin

aşağıdaki bağlantıyı inceleyebilirsiniz
http://gs1.tobb.org.tr/kontrol_basamagi_...2677940735
20/08/2019, 12:03

ozanakkaya

Verdiğim kod 13. basamağın hesaplama kodu.
20/08/2019, 12:13

ates2014

Sayın hocalarım, bu kodu nasıl uygulayacağım konusunda hiç bir fikrim yok,
mehmet hocanın bean13 için düzenlediği yani 12 ye sabitlediği kodu,
normal olan 13 rakama uyarlanması benim işimi görecek,
lütfen aşağıdaki kod grubunu düzenleyip verirseniz çok sevinirim.
'
Kod:
''''''''''''''' AcessTr.neT '''''''''''''''''''''''''''
Option Compare Database
Option Explicit

#If VBA7 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Sub DownloadFileFromWeb()
    Dim myFile As String
    Dim Ret As Long
    Dim strSavePath As String
    Dim URL As String

    URL = "http://www.accesstr.net/sitegenel/ean13.ttf"
    strSavePath = Environ("TEMP") & "\GeciciBarkod\ean13.ttf"
    Debug.Print strSavePath
    Ret = URLDownloadToFile(0, URL, strSavePath, 0, 0)

    If Ret = 0 Then
        Exit Sub
    Else
        MsgBox "Dosya Yüklenemedi"
    End If
End Sub

Public Function EAN13$(chaine$)

  Dim i%, checksum%, first%, CodeBarre$, tableA As Boolean
  EAN13$ = ""

  If Len(chaine$) = 12 Then

    For i% = 1 To 12
      If Asc(Mid$(chaine$, i%, 1)) < 48 Or Asc(Mid$(chaine$, i%, 1)) > 57 Then
        i% = 0
        Exit For
      End If
    Next
    If i% = 13 Then

      For i% = 12 To 1 Step -2
        checksum% = checksum% + Val(Mid$(chaine$, i%, 1))
      Next
      checksum% = checksum% * 3
      For i% = 11 To 1 Step -2
        checksum% = checksum% + Val(Mid$(chaine$, i%, 1))
      Next
      chaine$ = chaine$ & (10 - checksum% Mod 10) Mod 10

      CodeBarre$ = Left$(chaine$, 1) & Chr$(65 + Val(Mid$(chaine$, 2, 1)))
      first% = Val(Left$(chaine$, 1))
      For i% = 3 To 7
        tableA = False
        Select Case i%
        Case 3
          Select Case first%
          Case 0 To 3
            tableA = True
          End Select
        Case 4
          Select Case first%
          Case 0, 4, 7, 8
            tableA = True
          End Select
        Case 5
          Select Case first%
          Case 0, 1, 4, 5, 9
            tableA = True
          End Select
        Case 6
          Select Case first%
          Case 0, 2, 5, 6, 7
            tableA = True
          End Select
        Case 7
          Select Case first%
          Case 0, 3, 6, 8, 9
            tableA = True
          End Select
        End Select
      If tableA Then
        CodeBarre$ = CodeBarre$ & Chr$(65 + Val(Mid$(chaine$, i%, 1)))
      Else
        CodeBarre$ = CodeBarre$ & Chr$(75 + Val(Mid$(chaine$, i%, 1)))
      End If
    Next
      CodeBarre$ = CodeBarre$ & "*"
      For i% = 8 To 13
        CodeBarre$ = CodeBarre$ & Chr$(97 + Val(Mid$(chaine$, i%, 1)))
      Next
      CodeBarre$ = CodeBarre$ & "+"
      EAN13$ = CodeBarre$
    End If
  End If
End Function

Public Function DuzenleOnarYenile()
    Dim scriptpath As String
    Dim TimeOut As Integer
    scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat"
    If Dir(scriptpath, vbNormal) <> "" Then
        If DateAdd("s", TimeOut * 2, FileDateTime(scriptpath)) < Date Then
            Kill scriptpath
        Else
            Application.Quit acQuitSaveAll
            Exit Function
        End If
    End If
    Dim S As String
    S = S & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf
    S = S & "SET /a counter=0" & vbCrLf
    S = S & ":CHECKLOCKFILE" & vbCrLf
    S = S & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf
    S = S & "SET /a counter+=1" & vbCrLf
    S = S & "IF ""!counter!""==""" & TimeOut & """ GOTO CLEANUP" & vbCrLf
    S = S & "IF EXIST ""%~f2.%4"" GOTO CHECKLOCKFILE" & vbCrLf
    S = S & """%~f1"" ""%~f2.%3"" /compact" & vbCrLf
    S = S & "start "" "" ""%~f2.%3""" & vbCrLf
    S = S & ":CLEANUP" & vbCrLf
    S = S & "del %0"
    Dim intFile As Integer
    intFile = FreeFile()
    Open scriptpath For Output As #intFile
    Print #intFile, S
    Close #intFile
    Dim dbname As String, ext As String, lockext As String, accesspath As String
    Dim idx As Integer
    accesspath = SysCmd(acSysCmdAccessDir) & "msaccess.exe"
    For idx = Len(CurrentProject.FullName) To 1 Step -1
        If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For
    Next idx
    dbname = Left(CurrentProject.FullName, idx - 1)
    ext = Mid(CurrentProject.FullName, idx + 1)
    If Left(ext, 2) = "ac" Then
        lockext = "laccdb"
    Else
        lockext = "ldb"
    End If
    S = """" & scriptpath & """ """ & accesspath & """ """ & dbname & """ " & ext & " " & lockext
    Shell S, vbHide
  Application.Quit acQuitSaveAll
End Function
20/08/2019, 12:22

ates2014

Merhaba hocalarım,
If Len(chaine$) = 12 Then
bu satırı silince sorun kalmadı,
ilginiz için çok çok teşekkür ederim.

mehmet hoccanın bu satırı neden eklediğini bir türlü anlamadım,
siz biliyormusunuz?
20/08/2019, 12:44

ozanakkaya

(20/08/2019, 12:22)ates2014 yazdı: mehmet hoccanın bu satırı neden eklediğini bir türlü anlamadım,
siz biliyormusunuz?

Girilen veri 12 hane ise kodun çalışması için eklenmiş.
1 2 3 4 5 6 7 8 9