حدوث مشكلة عند تحديث موديول

[حمدى الظابط]

مشكلة عند تغير وتحديث  موديول

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

الموديول الاول يرسل منه صور الى الاميل وكان يعمل بكفاءة عالية ولا يوجد مشكلة فى ذلك

الموديول الاول ويتوافق مع ارسال الاميل
Option Compare Database
Option Explicit
Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (ofn As OPENFILENAME) As Boolean

Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
  "GetSaveFileNameA" (ofn As OPENFILENAME) As Boolean

Private Const ALLFILES = "All files"

Function MakeFilterString(ParamArray varFilt() As Variant) As String
  Dim strFilter As String
  Dim intRes As Integer
  Dim intNum As Integer

  intNum = UBound(varFilt)
  If (intNum <> -1) Then
    For intRes = 0 To intNum
      strFilter = strFilter & varFilt(intRes) & vbNullChar
    Next
    If intNum Mod 2 = 0 Then
      strFilter = strFilter & "*.*" & vbNullChar
    End If

    strFilter = strFilter & vbNullChar
  End If

  MakeFilterString = strFilter
End Function

Private Sub InitOFN(ofn As OPENFILENAME)
  With ofn
    .hwndOwner = hWndAccessApp
    .hInstance = 0
    .lpstrCustomFilter = vbNullString
    .nMaxCustFilter = 0
    .lpfnHook = 0
    .lpTemplateName = 0
    .lCustData = 0
    .nMaxFile = 511
    .lpstrFileTitle = String(512, vbNullChar)
    .nMaxFileTitle = 511
    .lStructSize = Len(ofn)
    If .lpstrFilter = "" Then
      .lpstrFilter = MakeFilterString(ALLFILES)
    End If
    .lpstrFile = .lpstrFile & String(512 - Len(.lpstrFile), vbNullChar)
  End With
End Sub

Function OpenDialog(ofn As OPENFILENAME) As Boolean
  Dim intRes As Integer
  InitOFN ofn
  intRes = GetOpenFileName(ofn)
  If intRes Then
    With ofn
      .lpstrFile = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1)
    End With
  End If
  OpenDialog = intRes
End Function

 وبعد التحديث الى ذلك اصبح يرسل صور الى الواتساب بكفاءة ولكن لاسف اصبح لا يرسل الصور الى الاميل

الموديول الثانى يرسل الى الواتساب ولا يرسل الى الاميل 

Option Compare Database
Option Explicit
Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

#If VBA7 Then
Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (ofn As OPENFILENAME) As Boolean

Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
  "GetSaveFileNameA" (ofn As OPENFILENAME) As Boolean
#Else
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (ofn As OPENFILENAME) As Boolean

Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
  "GetSaveFileNameA" (ofn As OPENFILENAME) As Boolean
#End If

#If VBA7 Then
    Public Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
#Else
    Public Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
#End If

Private Const ALLFILES = "All files"

Function MakeFilterString(ParamArray varFilt() As Variant) As String
  Dim strFilter As String
  Dim intRes As Integer
  Dim intNum As Integer

  intNum = UBound(varFilt)
  If (intNum <> -1) Then
    For intRes = 0 To intNum
      strFilter = strFilter & varFilt(intRes) & vbNullChar
    Next
    If intNum Mod 2 = 0 Then
      strFilter = strFilter & "*.*" & vbNullChar
    End If

    strFilter = strFilter & vbNullChar
  End If

  MakeFilterString = strFilter
End Function

Private Sub InitOFN(ofn As OPENFILENAME)
  With ofn
    .hwndOwner = hWndAccessApp
    .hInstance = 0
    .lpstrCustomFilter = vbNullString
    .nMaxCustFilter = 0
    .lpfnHook = 0
    .lpTemplateName = 0
    .lCustData = 0
    .nMaxFile = 511
    .lpstrFileTitle = String(512, vbNullChar)
    .nMaxFileTitle = 511
    .lStructSize = Len(ofn)
    If .lpstrFilter = "" Then
      .lpstrFilter = MakeFilterString(ALLFILES)
    End If
    .lpstrFile = .lpstrFile & String(512 - Len(.lpstrFile), vbNullChar)
  End With
End Sub

Function OpenDialog(ofn As OPENFILENAME) As Boolean
  Dim intRes As Integer
  InitOFN ofn
  intRes = GetOpenFileName(ofn)
  If intRes Then
    With ofn
      .lpstrFile = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1)
    End With
  End If
  OpenDialog = intRes
End Function

اريد التعديل على الموديول ليتوافق مع ارسال الاميل والوتساب معا

@ابو خليل

@Moosak

وجمعة مباركة

تجرية.rar

تم تعديل يناير 20, 2023 بواسطه حمدى الظابط

[حمدى الظابط]

شكرا تم الحل بعد تغير نسخة الوندوز 

ولكن عند ارسال رسالة اميل لعدد من السجلات لا يكتب فى حقل حالة الارسال تم الارسل الا لاخر سجل تم الارسال له واريد ان يكتب اما كل سجل ارسل له تم الارسال فى حقل خالة الارسال ولكم جزيل الشكر