اسف على الصورة
وهذه نسخة من الكود
والمشكلة في دالة isnothing يعطيني ال VBA رسالة الخطاء sub or function not defined
Option Compare Database
Dim ImageFilename, ImageFolder, AltFolder As String
'للتعامل مع السحب والافلات للصور
Private Sub DBPixM_ImageModified()
On Error Resume Next
DoCmd.RunCommand acCmdSaveRecord
Dim s As String
If DBPixM.ImageBytes < 1 Then
DocPic = Null
Else
'تسمية الصورة
s = WheelID & "_" & DocType & "_" & DocNumber & "-" & Format(DocDate, "dd-mm-yyyy") & "_" & DocID
s = Replace(s, "/", "_")
If DBPixM.ImageFormat = 1 Then 'jpeg
s = s & ".jpg"
Else
s = s & ".png"
End If
If isnothing(ImageFolder) Then
ImageFolder = CurrentFolder
ImageFilename = ImageFolder & s
'للتاكد من عدم تعارض اسماء الملفات
If fileexist(ImageFilename) Then
If MsgBox("لديك ملف بنفس الاسم وبنفس الموضع" & vbNewLine & "هل تريد استبدال الوثيقة؟", vbQuestion + vbYesNo + vbMsgBoxRight, "سئوال") = vbNo Then DBPixM.ImageViewFile ImageFilename: Exit Sub
End If
If DBPixM.ImageSaveFile(ImageFilename) Then
If isrelative(ImageFilename) Then
DocPic = Right(ImageFilename, Len(ImageFilename) - Len(CurrentProject.path) - 1)
ElseIf isnetpath(ImageFilename) Then
DocPic = Right(ImageFilename, Len(ImageFilename) - Len(CurrentFolder) + netpathlen(CurrentFolder))
Else
DocPic = ImageFilename
ImageFolder = Left(ImageFilename, InStrRev(ImageFilename, "\"))
End If
DoCmd.RunCommand acCmdSaveRecord
Else
UsMes.Caption = vbnnewline & "تعذر حفظ صورة الوثيقة"
DBPixM.ImageViewBlob (Null)
UsMes.Visible = True
DBPixM.Visible = False
End If
End If
End Sub
Private Sub Form_Current()
On Error Resume Next
Dim Tr As Boolean
UsMes.Visible = False: DBPixM.Visible = True
If Not isnothing(DocPic) Then
If istrimed(DocPic) Then
If IsNoPath(DocPic) Then
ImageFilename = CurrentFolder & "\" & DocPic
ElseIf isnetpath(CurrentFolder) Then
If InStr(CurrentFolder, Left(DocPic, InStr(DocPic, "\"))) > 0 Then
ImageFilename = CurrentFolder & Mid(DocPic, 1 + InStrRev(DocPic, "\"))
Else
ImageFilename = CurrentFolder & IIf(Left(DocPic, 1) = "\", "", "\") & DocPic
End If
Else
ImageFilename = CurrentProject.path & IIf(Left(DocPic, 1) = "\", "", "\") & DocPic
CurrentFolder = CurrentProject.path & "\"
Tr = True
End If
Else
ImageFilename = DocPic
End If
If fileexist(ImageFilename) Then
DBPixM.ImageViewFile ImageFilename
Else
If Tr Then ImageFilename = ImageFolder & DocPic
If fileexist(ImageFilename) Then
DBPixM.ImageViewFile ImageFilename
CurrentFolder = ImageFolder
Else
UsMes.Caption = vbNewLine & "صورة الوثيقة مفقودة"
UsMes.Visible = True
DBPixM.ImageViewBlob (Null)
CurrentFolder.SetFocus
DBPixM.Visible = False
End If
End If
ImageFolder = IIf(isnothing(AltFolder), Left(ImageFilename, InStrRev(ImageFilename, "\")), AltFolder)
Else
UsMes.Caption = vbNewLine & "اضف وثيقة جديدة"
UsMes.Visible = True
DBPixM.ImageViewBlob (Null)
CurrentFolder.SetFocus
DBPixM.Visible = False
End If
End Sub
Private Sub Form_Load()
'جعل مكان الحفظ عند التشغيل هو مكان البرنامج
CurrentFolder = CurrentProject.path
End Sub
