تعديل كود حفظ الصور بواسطة السكنر او النقل من الحاسوب

[omarAbdalrazaq]

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

اساتذتنا واخواننا في هذا المنتدى الجميل

ارجو افادتي حول تعديل الكود الخاص بالسكنر 

المطلوب:

تصغير حجم الصورة الماخوذة بالسكنر حيث ان كل صورة يبلغ حجمها 5 ميجا

تنبيهي الى الاخطاء الموجودة في الكود لغرض التعلم

هذا ولكم الاجر والثواب

تحياتي للجميع

Option Compare Database
Option Explicit


Dim destinationFolder As String
Dim myScanPath As String
Dim myScanPathWithID As String
Dim myImageFullName As String
Private Sub btnClose_Click()
DoCmd.Close
End Sub

Private Sub btnDelete_Click()
'Make Sure PicPath not Null
If IsNull(Path) Then
    MsgBox "لا بوجد مسار للصورة حتى تتم عملية الحذف", vbCritical + vbOKOnly, "نقص معلومات"
    Exit Sub
End If
On Error Resume Next
If MsgBox("سيتم حذف المرفق نهائيا ولا يمكن التراجع عن الحذف مرة اخري", _
    vbQuestion + vbYesNo + vbMsgBoxRight + vbDefaultButton2, _
    "تأكيد الحذف") = vbYes Then
DoCmd.RunCommand acCmdDeleteRecord
Else
DoCmd.CancelEvent
End If
End Sub

Private Sub btnHdd_Click()
'Make Sure EmpID not Null
If IsNull(EmpID) Or IsNull(TypeOfDocument) Or IsNull(DocumentNumber) Or IsNull(DocumentNumber) Or IsNull(FaceOrBack) Then
    MsgBox "يرجى اكمال المعلومات في الحقول قبل استعمال نسح صورة من الهارد", vbCritical + vbOKOnly, "نقص معلومات"
    Exit Sub
End If
Dim Syso As Object
Dim MyFile As String
myScanPath = "D:\MyScanDB"
myScanPathWithID = myScanPath & "\" & [EmpID]
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")

If Not fso.FolderExists(myScanPathWithID) Then
   fso.createfolder (myScanPathWithID)
End If

Dim Addfile As Object
Set Addfile = Application.FileDialog(3)
With Addfile
  .AllowMultiSelect = False
  .InitialFileName = ""
  .Filters.Clear
  .Filters.Add "All Files", "*.*"
  If .Show = True Then

MyFile = Trim(.SelectedItems(1))
destinationFolder = myScanPathWithID & "\" & [TypeOfDocument] & " " & [DocumentNumber] & " " & Format([DocumentDate], "yyyy-mm-dd") & " " & [FaceOrBack] & " " & Format([DateOfTransfer], "yyyy-mm-dd hh-mm-nn-ss") & ".jpg"
Me.Path = destinationFolder
DBEngine.Idle

Set Syso = CreateObject("Scripting.FileSystemObject")
Syso.copyfile MyFile, destinationFolder
Set Syso = Nothing
      Else
      Exit Sub
  End If
End With
End Sub

Private Sub btnPrevew_Click()
DoCmd.GoToControl "Path"
If IsNull(Me![Path]) Then
        MsgBox "لايوجد مرفق"
    Else
   Application.FollowHyperlink [Path]
End If
Exit_btnHdd_Click:
    Exit Sub

Err_btnHdd_Click:
    MsgBox Err.Description
    Resume Exit_btnHdd_Click
End Sub

Private Sub btnScaner_Click()
'Make Sure EmpID not Null
If IsNull(EmpID) Or IsNull(TypeOfDocument) Or IsNull(DocumentNumber) Or IsNull(DocumentNumber) Or IsNull(FaceOrBack) Then
    MsgBox "يرجى اكمال المعلومات في الحقول قبل استعمال السكنر", vbCritical + vbOKOnly, "نقص معلومات"
    Exit Sub
End If
myScanPath = "D:\MyScanDB"
myScanPathWithID = myScanPath & "\" & [EmpID]
myImageFullName = ""



'Make Sure Folder Exsist if Not Create One
destinationFolder = Dir(myScanPathWithID, vbDirectory)
If destinationFolder = vbNullString Then
    VBA.FileSystem.MkDir (myScanPathWithID)
End If

Dim hg, OldFile, DBwithEXT
Dim fdialog As Office.FileDialog
Dim filepath As String
Dim sdialog As New WIA.CommonDialog
Dim imagefile As WIA.imagefile

On Error GoTo errorhandle

Set fdialog = Application.FileDialog(msoFileDialogSaveAs)
OldFile = myScanPathWithID
DBwithEXT = Dir(OldFile)


hg = myScanPathWithID & "\" & [TypeOfDocument] & " " & [DocumentNumber] & " " & Format([DocumentDate], "yyyy-mm-dd") & " " & [FaceOrBack] & " " & Format([DateOfTransfer], "yyyy-mm-dd hh-mm-nn-ss") & Right(DBwithEXT, 3)

With fdialog
            .Title = "Save as"
            .AllowMultiSelect = False
            .InitialFileName = [hg]
            .InitialFileName = hg + ".bmp"
            
            
            If .Show Then
                filepath = .SelectedItems(1)
'
                Else
                Exit Sub
            End If
            Set imagefile = sdialog.ShowAcquireImage()
            imagefile.SaveFile filepath
            Me.Path = filepath
End With
errorhandleexit:
        Exit Sub
errorhandle:
        MsgBox Err.Description
        Resume errorhandleexit
        


End Sub

 

MyPic.rar

[omarAbdalrazaq]

يا الله