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