Newsgroup: it.comp.appl.access
Titolo: limiti di CDO.Message

Sto usando CDO.Message
ma ho dei problemi in quanto sembra che dopo un certo numeri di caratteri nel
"body", si blocchi.
l'invio funziona benissimo, l'unica cosa č che dopo circa 900 battute interrompe
il testo del body.
che voi sappiate c'č un limite di testo massimo che puň contenere?
grazie
Ciao
Silvia.
--
www.silvietta.it
...everyone's invited!
Kann ein Herz aus Stein sein??

mi sembra sia un problema riconosciuto da M$, con ACCESS.
sul sito ho adattato una serie di proc.... non so se ti può servire,
sostituisce il sendobject di access.
CIao
Option Compare Database
Option Explicit
'Private MAPISession As MAPI.Session
'Private MAPIMessage As message
'Private MAPIRecipient As MAPI.Recipient
'Private MAPIAttachment As MAPI.Attachment
Private MAPISession As Object
Private MAPIMessage As Object
Private MAPIRecipient As Object
Private MAPIAttachment As Object
Private reciparray() As String
Private strFileName As String
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Const HKEY_CURRENT_USER = &H80000001
Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0
Private Declare Function GetVersionEx Lib "kernel32" _
   Alias "GetVersionExA" _
         (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
         (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
   Alias "RegOpenKeyExA" _
         (ByVal hKey As Long, _
         ByVal lpSubKey As String, _
         ByVal ulOptions As Long, _
         ByVal samDesired As Long, _
         phkResult As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" _
   Alias "RegQueryValueExA" _
         (ByVal hKey As Long, _
         ByVal lpValueName As String, _
         ByVal lpReserved As Long, _
         lpType As Long, _
         ByVal lpData As String, _
         lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" _
   Alias "RegQueryValueExA" _
         (ByVal hKey As Long, _
         ByVal lpValueName As String, _
         ByVal lpReserved As Long, _
         lpType As Long, lpData As Long, _
         lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" _
   Alias "RegQueryValueExA" _
         (ByVal hKey As Long, _
         ByVal lpValueName As String, _
         ByVal lpReserved As Long, _
         lpType As Long, _
         ByVal lpData As Long, _
         lpcbData As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" _
         Alias "GetTempPathA" (ByVal nBufferLength As Long, _
         ByVal lpBuffer As String) As Long
'Public Enum accSendObjectOutputFormat
Public Const accOutputRTF = 1
    Public Const accOutputTXT = 2
    Public Const accOutputSNP = 3
    Public Const accOutputXLS = 4
    Public PostaOK As Boolean
'End Enum
Public Sub ACCSendObject(Optional ObjectType As Long = acSendNoObject, _
                      Optional ObjectName, _
                      Optional OutputFormat As Long, _
                      Optional EmailAddress, _
                      Optional CC, _
                      Optional BCC, _
                      Optional Subject, _
                      Optional MessageText, _
                      Optional EditMessage)
    Dim strTmpPath As String * 512
    Dim sTmpPath As String
    Dim strExtension As String
    Dim nRet As Long
If Val(SysCmd(acSysCmdAccessVer)) <= 8 Then
    OutputFormat = 1
 
Else
    OutputFormat = 3
End If
PostaOK = False
    StartMessagingAndLogon
    Set MAPIMessage = MAPISession.Outbox.Messages.Add
    If ObjectType <> -1 Then
        If IsMissing(ObjectName) Or IsMissing(OutputFormat) Then
            MsgBox "The object type, name, or output format is not valid.
Cannot send message.", vbCritical
            MAPISession.Outbox.Messages.Delete
            GoTo accSendObject_Exit
        Else
            strExtension = GetExtension(OutputFormat)
            nRet = GetTempPath(512, strTmpPath)
            If (nRet > 0 And nRet < 512) Then
                If InStr(strTmpPath, Chr(0)) > 0 Then
                    sTmpPath = RTrim(Left(strTmpPath, InStr(1, strTmpPath,
Chr(0)) - 1))
                End If
                strFileName = sTmpPath & ObjectName & strExtension
            End If
            On Error Resume Next
            DoCmd.OutputTo ObjectType, ObjectName,
GetOutputFormat(OutputFormat), strFileName, False
            If Err.Number = 0 Then
                Set MAPIAttachment = MAPIMessage.Attachments.Add
                With MAPIAttachment
                    .Name = ObjectName
                    .Type = 1
                    .source = strFileName
                End With
                CancellaFile strFileName
            Else
                If Err.Number <> 2501 Then
                    MsgBox "The object type, name, or output format is not
valid. Cannot send message.", vbCritical
                End If
                    MAPISession.Outbox.Messages.Delete
                    GoTo accSendObject_Exit
 
            End If
        End If
    End If
    If Not IsMissing(EmailAddress) Then
        MySplit EmailAddress, ";", reciparray()
        ParseAddress 1
        Erase reciparray
    End If
    If Not IsMissing(CC) Then
        MySplit CC, ";", reciparray
        ParseAddress 2
        Erase reciparray
    End If
    If Not IsMissing(BCC) Then
        MySplit BCC, ";", reciparray
 
        ParseAddress 3
        Erase reciparray
    End If
    If Not IsMissing(Subject) Then
        MAPIMessage.Subject = Subject
    End If
    If Not IsMissing(MessageText) Then
        MAPIMessage.Text = MessageText
    End If
    If IsMissing(EditMessage) Then EditMessage = True
    MAPIMessage.ReadReceipt = True
    MAPIMessage.Update
    On Error Resume Next
    MAPIMessage.Send savecopy:=True, ShowDialog:=EditMessage
    If Err.Number = 0 Then
        If MAPIMessage.Sent Then
            PostaOK = True
        Else
            PostaOK = False
            MAPIMessage.Delete
        End If
    Else
        If Err.Number <> 2501 And Err.Number <> -
2147221229
 Then
            'MsgBox "The object type, name, or output format is not valid.
Cannot send message.", vbCritical
            MsgBox (Str(Err.Number) & " " & Err.Description)
        End If
            MAPIMessage.Delete
            GoTo accSendObject_Exit
 
    End If
accSendObject_Exit:
    'Log off the MAPI session.
    MAPISession.Logoff
    Set MAPIAttachment = Nothing
    Set MAPIRecipient = Nothing
    Set MAPIMessage = Nothing
    Set MAPISession = Nothing
    Exit Sub
End Sub
Private Sub ParseAddress(RecipientType As Long)
    Dim I As Variant
    For Each I In reciparray
        Set MAPIRecipient = MAPIMessage.Recipients.Add
        With MAPIRecipient
            .Name = I
            .Type = RecipientType
            .Resolve
        End With
        Set MAPIRecipient = Nothing
    Next
End Sub
Private Function GetExtension(ObjectType As Long) As String
    Select Case ObjectType
        Case 1 'RTF
            GetExtension = ".RTF"
        Case 2 'TXT
            GetExtension = ".TXT"
        Case 3 'SNP
            GetExtension = ".SNP"
        Case 4 'XLS
            GetExtension = ".XLS"
    End Select
End Function
Private Function GetOutputFormat(ObjectType As Long)
    Select Case ObjectType
        Case 1 'RTF
            GetOutputFormat = Access.acFormatRTF
        Case 2 'TXT
            GetOutputFormat = Access.acFormatTXT
        Case 3 'SNP
            GetOutputFormat = "Snapshot Format (*.snp)"
        Case 4 'XLS
            GetOutputFormat = Access.acFormatXLS
    End Select
End Function
Private Sub StartMessagingAndLogon()
    Dim sKeyName As String
    Dim sValueName As String
    Dim sDefaultUserProfile As String
    Dim osinfo As OSVERSIONINFO
    Dim retvalue As Integer
    On Error GoTo ErrorHandler
    Set MAPISession = CreateObject("MAPI.Session")
    'Try to log on.  If this fails, the most likely reason is
    'that you do not have an open session.  The error
    '-
2147221231
  MAPI_E_LOGON_FAILED returns.  Trap
    'the error in the ErrorHandler.
    MAPISession.Logon ShowDialog:=False, NewSession:=False
    Exit Sub
ErrorHandler:
    Select Case Err.Number
       Case -
2147221231
  'MAPI_E_LOGON_FAILED
          'Need to determine what operating system is in use. The keys are
different
          'for WinNT and Win95.
          osinfo.dwOSVersionInfoSize = 148
          osinfo.szCSDVersion = Space$(128)
          retvalue = GetVersionEx(osinfo)
          Select Case osinfo.dwPlatformId
             Case 0   'Unidentified
                MsgBox "Unidentified Operating System.  " & _
                   "Cannot log on to messaging."
                Exit Sub
             Case 1   'Win95
                sKeyName = "Software\Microsoft\" & _
                           "Windows Messaging " & _
                           "Subsystem\Profiles"
             Case 2   'NT
                 sKeyName = "Software\Microsoft\Windows NT\" & _
                            "CurrentVersion\" & _
                            "Windows Messaging Subsystem\Profiles"
          End Select
          sValueName = "DefaultProfile"
          sDefaultUserProfile = QueryValue(sKeyName, sValueName)
          MAPISession.Logon ProfileName:=sDefaultUserProfile, _
                           ShowDialog:=False
          Exit Sub
       Case Else
          MsgBox "An error has occured while trying" & Chr(10) & _
          "to create and to log on to a new ActiveMessage session." & _
          Chr(10) & "Report the following error to your " & _
          "System Administrator." & Chr(10) & Chr(10) & _
          "Error Location: frmMain.StartMessagingAndLogon" & _
          Chr(10) & "Error Number: " & Err.Number & Chr(10) & _
          "Description: " & Err.Description
    End Select
End Sub
Private Function QueryValue _
    (sKeyName As String, _
    sValueName As String)
    Dim lRetVal As Long     'Result of the API functions.
    Dim hKey As Long        'Handle of the opened key.
    Dim vValue As Variant   'Setting of the queried value.
    lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, _
                sKeyName, _
                0, _
                KEY_ALL_ACCESS, _
                hKey)
    lRetVal = QueryValueEx(hKey, _
                sValueName, _
                vValue)
    QueryValue = vValue
    RegCloseKey (hKey)
End Function
Private Function QueryValueEx _
       (ByVal lhKey As Long, _
       ByVal szValueName As String, _
       vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String
    On Error GoTo QueryValueExError
    ' Determine the size and the type of the data to be read.
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5
    Select Case lType
       ' For strings
       Case REG_SZ:
          sValue = String(cch, 0)
          lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
             sValue, cch)
          If lrc = ERROR_NONE Then
             vValue = Left$(sValue, cch)
          Else
             vValue = Empty
          End If
       ' For DWORDS
       Case REG_DWORD:
          lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
             lValue, cch)
          If lrc = ERROR_NONE Then vValue = lValue
       Case Else
          'All other data types that are not supported.
          lrc = -1
    End Select
QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
QueryValueExError:
    Resume QueryValueExExit
    End Function
-- 
questo articolo e` stato inviato via web dal servizio gratuito 
http://www.newsland.it/news
 segnala gli abusi ad 
ab...@newsland.it