Ver Mensaje Individual
  #6 (permalink)  
Antiguo 07/09/2004, 10:04
NiñaC
 
Fecha de Ingreso: enero-2004
Mensajes: 23
Antigüedad: 21 años, 3 meses
Puntos: 0
Gracias chicos, consulto las páginas que me dicen y les aviso, les copio el código de VB: tiene 1 form, 2 módulos y 2 módulos de clase y las referencias y componentes del Groupwise

Código:
Form1:

Option Explicit

Private Sub Command1_Click()
        If lstDisplayName.ListCount > 0 Then
           Call groupwise
        End If
        lstDisplayName.Clear
        lstDepartment.Clear

End Sub

Private Sub Form_Load()
        Set MyRecipients = New Recipients

        lstDisplayName.Clear
        lstDepartment.Clear
End Sub

Private Sub groupwise()
On Error GoTo cmdSendMail_Click_Error
Dim MyRecipient As Recipient
Dim i As Integer
For i = 0 To lstDisplayName.ListCount - 1
     MyRecipients.Add lstDisplayName.List(i)
Next
Dim usuarioactivo As String
Dim clavegroupwise As String
usuarioactivo = UCase(SystemLogonName)
'If isgSendMail(usuarioactivo, clavegroupwise, "mensaje", "asunto", "") Then
If isgSendMail(usuarioactivo, clavegroupwise, Trim("Envio de memo via groupwise" + " " + "Favor enviar respuesta al usuario del GroupWise: MemosMetro, para ver el archivo adjunto debe utilizar la aplicación Microsoft Word"), "Memo No. ", App.Path + "\memos.doc") Then

   MsgBox "El mensaje ha sido enviado via GroupWise...", vbInformation
   Set MyRecipients = Nothing
   Set MyRecipients = New Recipients
End If
  Exit Sub
cmdSendMail_Click_Error:
    MsgBox Error$, vbInformation
    
End Sub

Private Sub GWab1_Click()
Call Update
End Sub


Private Sub Update()
    Dim nCount As Integer
    Dim sString As String
    Dim nIndex As Integer
    nCount = GWab1.TargetType(eTargetType_All)
    For nIndex = 0 To nCount - 1
        sString = GWab1.DisplayName(nIndex)
        lstDisplayName.AddItem sString
        sString = GWab1.Department(nIndex)
        lstDepartment.AddItem sString
    Next
End Sub



Módulo Basutilities:

Option Explicit

Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer

Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Const HEX_BMP_KEY As String = "424D"
Public Const HEX_GIF_KEY As String = "4749"
Public Const HEX_JPG_KEY As String = "4A464946"
Public Const HEX_BYTE_SIZE As Long = 9
Public Const BLOCKSIZE = 32768

Sub CenterForm(frmForm As Form)
On Error GoTo CenterFormError

frmForm.Left = Screen.Width / 2 - frmForm.Width / 2
frmForm.Top = Screen.Height / 2 - frmForm.Height / 2

CenterFormContinue:
    Exit Sub
CenterFormError:
    MsgBox Error$, vbExclamation
    Resume CenterFormContinue
End Sub

Function GetFileFromPath(sFilePath) As String
On Error GoTo GetFileFromPathError

Dim sFileTitle As String * 1024
Dim lRetVal As Long

lRetVal = GetFileTitle(sFilePath, sFileTitle, Len(sFileTitle))
GetFileFromPath = Mid(sFileTitle, 1, InStr(sFileTitle, Chr(0)) - 1)

GetFileFromPathContinue:
    Exit Function
GetFileFromPathError:
    MsgBox Error$, vbExclamation
    Resume GetFileFromPathContinue
End Function

Function SystemLogonName() As Variant
On Error GoTo SystemLogonNameError

Dim sUserName As String
Dim lRetVal As Long

sUserName = String(2048, 32)
lRetVal = GetUserName(sUserName, Len(sUserName) - 1)
'See if there is no one logged in.
If InStr(sUserName, Chr(0)) > 0 Then
    SystemLogonName = Mid(sUserName, 1, InStr(sUserName, Chr(0)) - 1)
Else
    SystemLogonName = "Unknown"
End If

SystemLogonNameContinue:
    Exit Function
SystemLogonNameError:
    MsgBox Error$, vbExclamation
    Resume SystemLogonNameContinue
End Function



Modulo1:
Option Explicit

Public gsRecipient As String
Public MyRecipients As Recipients
Public Declare Function RC Lib "c:\novell\groupwise\gwcma1.dll" _
Alias "DllRegisterServer" () As Long
Public Declare Function URC Lib "c:\novell\groupwise\gwcma1.dll" _
Alias "DllUnregisterServer" () As Long
Public GWApp As Application
Public GWRootAccount As Account
Public Const S_OK = &H0

Public Function isgSendMail(sUserID As String, sPassword As String, sMessage As String, sSubject As String, Optional sFilePath As String = "")
On Error GoTo isgSendMail_Error

Set GWApp = New Application
Dim MyFolder As Folder
Set GWRootAccount = GWApp.Login(sUserID, , sPassword)
Dim MyMessage As Message
Dim sFID As Variant
Dim MyRecipient As Recipient

'Determine wich folder will create the message normally Mailbox
isgSendMail = True

For Each MyFolder In GWApp.RootAccount.AllFolders
    If MyFolder.Name = "Buzón" Then
        'Return the folder ID
        sFID = MyFolder.FolderID
        Exit For
    End If
Next


'Set the Folder with the Mailbox folder ID
Set MyFolder = GWRootAccount.GetFolder(sFID)

'Start message
Set MyMessage = MyFolder.Messages.Add

'Message Info
MyMessage.Subject = sSubject
MyMessage.BodyText = sMessage

'Optional Settings
MyMessage.FromText = "mensaje3"

'Loop through the objects to return the Email Addresses

For Each MyRecipient In MyRecipients
    'USE THIS LINE FOR INTERNAL NAMEING LIKE JOHN DOE instead of [email protected]
    
    'MyMessage.Recipients.Add MyRecipient.EmailAddress, "NGW", "egwTo"
    
    MyMessage.Recipients.Add MyRecipient.EmailAddress
    
Next

If sFilePath <> "" Then
    MyMessage.Attachments.Add sFilePath, egwFile, GetFileFromPath(sFilePath)
End If

MyMessage.Send
'MyMessage.Delete
Set MyMessage = Nothing

isgSendMail_Resume:
    Exit Function
isgSendMail_Error:
    isgSendMail = False
    MsgBox Error$, vbInformation
    Resume isgSendMail_Resume
End Function


Sub RegisterControlSub()
On Error GoTo E
If RC = S_OK Then
Else
End If
Exit Sub
E: MsgBox "Error: " & Err.Number & " " & Err.Description, vbCritical, ""
End Sub
Sub UnRegisterControlSub()
On Error GoTo U
If URC = S_OK Then
Else
End If
Exit Sub
U: MsgBox "Error: " & Err.Number & " " & Err.Description, vbCritical, ""
End Sub


Sub Main()
 If App.PrevInstance Then
     End
 End If
    Set MyRecipients = New Recipients
    'RegisterControlSub
    Form1.Show vbModal
End Sub



Modulo de clase Recipient:

Option Explicit


Public mvarEmailAddress As Variant

Public Property Let EmailAddress(vData As Variant)
    mvarEmailAddress = vData
End Property

Public Property Get EmailAddress() As Variant
    EmailAddress = mvarEmailAddress
End Property



Módulo de clase Recipients:

Option Explicit

Public mCol As Collection

Public Function Add(EmailAddress As Variant) As Recipient

    Dim oRecipient As Recipient
    Set oRecipient = New Recipient

    oRecipient.EmailAddress = EmailAddress
    
    mCol.Add oRecipient
    Set Add = oRecipient
    Set oRecipient = Nothing
    
End Function

Public Property Get Item(vntIndexKey As Variant) As Recipient
  Set Item = mCol(vntIndexKey)
End Property

Public Property Get Count() As Long
    Count = mCol.Count
End Property

Public Sub Remove(vntIndexKey As Variant)
    Dim vItem As Recipient
    Dim l As Long
    
    l = 1
    For Each vItem In mCol
        
        If vItem.EmailAddress = vntIndexKey Then
            mCol.Remove l
        End If
        
        l = l + 1
    Next
End Sub

Public Property Get NewEnum() As IUnknown
    Set NewEnum = mCol.[_NewEnum]
End Property

Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

Private Sub Class_Terminate()
    Set mCol = Nothing
End Sub
Y ese es todo el código, porfis si me pueden explicar mas o menos o logran pasarlo a dll les agradezco que me expliquen como, gracias

Última edición por NiñaC; 07/09/2004 a las 13:42 Razón: Colocar dentro de tag