none
Imagem na Assinatura Aleatório RRS feed

  • Pergunta

  • Boas Pessoal,

    Alguém já precisou criar um script que colocasse na assinatura do Outlook uma imagem aleatória de um conjunto de imagens em uma pasta?

    Existe um script que cria assinaturas baseada na info colocada nos Atributos Ldap na AD (vide em http://lab.technet.microsoft.com/en-us/magazine/cc160913), o mesmo pode adicionar uma imagem. O pretendido seria adicionar uma imagem aleatória de uma grupo delas.

    O melhor que consegui encontrar na net foi neste site http://www.nangets.net/?p=151 mas que cria aleatóriamente textos. Ele coloca o código no Editor de VB do Outlook e cada vez que é aberta uma mensagem e enviada um texto diferente é enviado.

    Alguém sabe como fazer ou tenha feito algo parecido?


    Cláudio Gonçalves
    segunda-feira, 1 de agosto de 2011 15:50

Respostas

  • Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    
     ' Validate that the item sent is an email.
    
     If Item.Class <> olMail Then Exit Sub
    
    
    
     Const SearchString = "%Random_Line%"
    
     Const QuotesFile = "C:\Users\Administrator\Desktop\quotes.txt"
    
     MsgBox ("Passo1")
    
     If InStr(Item.Body, SearchString) Then
    
      If FileOrDirExists(QuotesFile) = False Then
    
       MsgBox ("Quotes file wasn't found! Canceling message")
    
       Cancel = True
    
      Else
    
       Dim lines() As String
    
       Dim numLines As Integer
    
       numLines = 0
    
    
    
       ' Open the file for reading
    
       Open QuotesFile For Input As #1
    
       MsgBox ("Passo2")
    
    
    
       ' Go over each line in the file and save it in the array + count it
    
       Do Until EOF(1)
    
        ReDim Preserve lines(numLines + 1)
    
        Line Input #1, lines(numLines)
    
        numLines = numLines + 1
    
       Loop
    
       MsgBox ("Passo3")
    
       Close #1
    
    
    
       ' Get the random line number
    
       Dim randLine As Integer
    
       randLine = Int(numLines * Rnd()) + 1
    
       ' Insert the random quote
    
       Item.HTMLBody = Replace(Item.HTMLBody, SearchString, "<img src=""http://servidor/" & lines(randLine) & " ""/>")
    
       MsgBox ("<img src=""http://servidor/" & lines(randLine) & " ""/>")
    
       Item.HTMLBody = Replace(Item.HTMLBody, "%Random_Num%", "<img src=""http://servidor/" & randLine & " ""/>")
    
       MsgBox ("<img src=""http://servidor/" & randLine & " ""/>")
    
      End If
    
     End If
    
    End Sub
    
    
    
    Function FileOrDirExists(PathName As String)
    
     Dim iTemp As Integer
    
    
    
     On Error Resume Next
    
     iTemp = GetAttr(PathName)
    
    
    
     Select Case Err.Number
    
     Case Is = 0
    
      FileOrDirExists = True
    
      MsgBox ("Passo4")
    
     Case Else
    
      FileOrDirExists = False
    
      MsgBox ("Passo5")
    
     End Select
    
    
    
     On Error GoTo 0
    
    End Function
    
    
    
    


    segue o codigo todo...

    Lembrando nao funcionou em 2007...:(

    Abraços...

     


    Edson Matias Fagundes Junior (Nioks)
    terça-feira, 2 de agosto de 2011 20:32

Todas as Respostas

  • Boa tarde Cláudio, não consegui fazer testes mas veja se lhe ajuda ok.

    http://www.brettb.com/RandomImageSelector.asp

     Abraços.


    Edson Matias Fagundes Junior (Nioks)

    segunda-feira, 1 de agosto de 2011 17:31
  • Claudio achei legal sua pergunta e util dai resolvi aplicar ao meu abiente segue modelo de script que uso para aplicar assinatura automaticamente e agora com image rand.

     

     

    'Declare variables
    
    Dim CompleteImagesFolderPath
    Dim FileSystemObject
    Dim ImageFolder
    Dim Files
    Dim i
    Dim ImageFiles
    Dim File
    Dim FileName
    Dim FileExtension
    Dim RandomNumber
    
    
    'Find the complete path to image folder by using Server.MapPath
    CompleteImagesFolderPath = "C:\Users\Public\Pictures\Sample Pictures\"
    
    'Create an instance of the FileSystemObject which allows ASP to
    'access the file system 
    Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
    
    'Check that the folder containing the images exists
    If Not FileSystemObject.FolderExists(CompleteImagesFolderPath) Then
    RandomImage = "Error 0: Cannot find requested folder"
    Set FileSystemObject = nothing
    'Exit Function
    End If
    
    'Get the folder containing the images
    Set ImageFolder = FileSystemObject.GetFolder(CompleteImagesFolderPath)
    
    'Get a list of all the files within the images folder
    Set Files = ImageFolder.Files
    
    'Use a dictionary object to temporarily store the image file names
    i = 1
    Set ImageFiles = CreateObject("Scripting.Dictionary")
    
    'Loop through the list of files within the images folder.
    'If the file has a file extension that is in the list of
    'file types specified in the ImageFileTypes function parameter,
    'then add the file name to the ImageFiles dictionary object
    For Each File in Files
    
    FileName = File.Name
    ImageFiles.Add i, FileName
    i = i + 1
    
    Next
    
    'Destroy objects that are no longer required
    Set ImageFolder = nothing
    Set Files = nothing
    Set FileSystemObject = nothing
    
    'Initialise the random number generator
    Randomize
    
    ' Check that image file(s) have been found
    If ImageFiles.Count = 0 Then
    RandomImage = "Error 1: Requested folder does not contain any image files"
    'Exit Function
    End If
    
    'Generate a random number between 1 and the number of image files
    RandomNumber = Int((ImageFiles.Count) * Rnd + 1)
    
    'Return a hyperlink to a random image file
    RandomImage = ImageFiles.Item(RandomNumber)
    Set ImageFiles = nothing
    
    '*******************************************FIM FUNÇÃO RANDON**********************************************
    
    Const END_OF_STORY = 6
    Const wdFormatHTML = 8
    
    On Error Resume Next
    Set objSysInfo = CreateObject("ADSystemInfo")
    strUser = objSysInfo.UserName
    Set objUser = GetObject("LDAP://" & strUser)
    With objUser
     strName = .FullName
     strTitle = .Description
    End With
    
    strCompany = objUser.Company
    strl = objUser.l
    strco = objUser.co
    strPhone = objUser.TelephoneNumber
    strFax = objUser.facsimileTelephoneNumber
    strMobile = objUser.Mobile
    strWeb = objuser.wWWHomePage
    strUserName = objuser.sAMAccountName
    
    Set objword = CreateObject("Word.Application")
    With objword
    
     Set objDoc = .Documents.Add()
     Set objSelection = .Selection
     Set objEmailOptions = .EmailOptions
     
     Set objRange = objDoc.Range()
     objDoc.Tables.Add objRange,1,2
     Set objTable = objDoc.Tables(1)
    
    End With
    
    Set objSignatureObject = objEmailOptions.EmailSignature
    Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
    MsgBox (http://servidor/& RandomImage)
    With objSelection
    
    objTable.Rows.Add()
      
      objTable.Cell(2, 1).Range.InlineShapes.AddPicture "http://servidor/"&RandomImage,true,True
      objTable.Columns(1).Width = objWord.InchesToPoints(1)
    
     objTable.Cell(2, 2).Select
      With .Font
     .Name = "Verdana"
     .Size = 10
     .Bold = True
     .Color = 0
      End With
     .TypeText strName & Chr(11)
     '.TypeParagraph()
    
     With .Font
     .Name = "Verdana"
     .Size = 8
     .Bold = False
     .Italic = False
     .Color = 0
     End With
     .TypeText strTitle & Chr(11) & "Tel. " & strPhone & Chr(11) & "Cel. " & strMobile & Chr(11) & "Fax. " & strFax & Chr(11) & "Site. " & strWeb & Chr(11)
     '.TypeParagraph()
     
     objTable.Columns(2).Width = objWord.inchesToPoints(0) 
    
    objSelection.EndKey END_OF_STORY 
    
     objSelection.Font.Name = "Verdana"
     objSelection.Font.Size = "8"
     objSelection.Font.italic = true
     objSelection.Font.Color = Black
     objSelection.Font.Bold = False 
     objSelection.TypeText "Esta mensagem e seus anexos são confidenciais e talvez privilegiados. Se você não é o destinatário, por favor notifique o remetente imediatamente e não divulgue o conteúdo para terceiros, tampouco use para outros propósitos ou armazene tais informações."
     .TypeText Chr(11)
     .TypeText Chr(11)
     objSelection.Font.italic = true
     objSelection.Font.Color = 240240 
     objSelection.Font.Bold = False 
     objSelection.TypeText "* PENSE NA NATUREZA ANTES DE IMPRIMIR."
    
    
     End With
    
    
    
    Set objSelection = objDoc.Range()
    objSignatureEntries.Add "Padrao Leonardi", objSelection
    objSignatureObject.NewMessageSignature = "Padrao Leonardi"
    objSignatureObject.ReplyMessageSignature = "Padrao Leonardi"
    objDoc.SaveAs "\\servidor\sys\assinaturas\" & strUserName & ".htm", wdFormatHTML
    objDoc.Saved = True
    objword.Quit
    
    Abraços

     


    Edson Matias Fagundes Junior (Nioks)
    segunda-feira, 1 de agosto de 2011 19:32
  • Edson, o seu Script funciona bem e muito obrigado pela ajuda, mas tem um senão.

    Da forma como está, precisará ser colocado como Logon Script correcto?

    Para o pretendido a imagem aleatória precisa ser a cada envio de e-mail e não a cada logon. Com usuários de laptops poderá ficar complicado. Um dos motivos de ter colocado este link  http://www.nangets.net/?p=151, é que o cara introduz o código na sessão do Outlook via a Tab Developer, depois adicionar uma variavel no texto do email o que achei bastante funcional.

    Não sei programar de raiz, gerlamente adapto os códigos às minhas necessidades, por isso peço ajuda :-)

    É possível adaptar o seu código para ser usado como nesse link desse cara?


    Cláudio Gonçalves
    terça-feira, 2 de agosto de 2011 08:16
  • Cláudio, desculpe... eu realmente apliquei ao meu ambiente...

    Vou verificar se consigo lhe ajudar ok...

    Abraços

     


    Edson Matias Fagundes Junior (Nioks)
    terça-feira, 2 de agosto de 2011 12:55
  • Cara nao consegui fazer funcionar em office 2007... deu certo no seu????
    Edson Matias Fagundes Junior (Nioks)
    terça-feira, 2 de agosto de 2011 13:53
  • Estás a falar do código para colocar no Developer?

    Eu estou a usar o Office 2010 e correr sem problemas.

    Gravei antes de fechar a sessão e coloquei a variavél sem problemas.

    no ficheiro de texto é importante dar ENTER para separar as linhas.


    Cláudio Gonçalves
    terça-feira, 2 de agosto de 2011 14:19
  • Vamos lá... consultando esse codigo que voce mandou como exemplo eu criei um arquivo com uma lista de arquivos que tenho publicado na internet... as tais imagens...

    Alterei o script do colega para +/- atender sua necessidade ou para atender...
    Como no proprio exemplo ele tem que colocar o %Random_Line%
    Alterei essa parte do codigo aqui funcionou se voque quiser mando o codigo todo mas nao acho necessario pois coloquei um monte de ponto de verificação...
    rsrssrs...

    Posso dizer que deu um trabalhinho mas valeu apena.

    Abraços


                ' Insert the random quote
                Item.HTMLBody = Replace(Item.HTMLBody, SearchString, "<img src=""http://servidor/" & lines(randLine) & " ""/>")
               ' MsgBox ("<img src=""http://servidor/" & lines(randLine) & " ""/>")
                Item.HTMLBody = Replace(Item.HTMLBody, "%Random_Num%", "<img src=""http://servidor/" & randLine & " ""/>")
                'MsgBox ("<img src=""http://servidor/" & randLine & " ""/>")
            End If

     


    Edson Matias Fagundes Junior (Nioks)

    terça-feira, 2 de agosto de 2011 20:05
  • Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    
     ' Validate that the item sent is an email.
    
     If Item.Class <> olMail Then Exit Sub
    
    
    
     Const SearchString = "%Random_Line%"
    
     Const QuotesFile = "C:\Users\Administrator\Desktop\quotes.txt"
    
     MsgBox ("Passo1")
    
     If InStr(Item.Body, SearchString) Then
    
      If FileOrDirExists(QuotesFile) = False Then
    
       MsgBox ("Quotes file wasn't found! Canceling message")
    
       Cancel = True
    
      Else
    
       Dim lines() As String
    
       Dim numLines As Integer
    
       numLines = 0
    
    
    
       ' Open the file for reading
    
       Open QuotesFile For Input As #1
    
       MsgBox ("Passo2")
    
    
    
       ' Go over each line in the file and save it in the array + count it
    
       Do Until EOF(1)
    
        ReDim Preserve lines(numLines + 1)
    
        Line Input #1, lines(numLines)
    
        numLines = numLines + 1
    
       Loop
    
       MsgBox ("Passo3")
    
       Close #1
    
    
    
       ' Get the random line number
    
       Dim randLine As Integer
    
       randLine = Int(numLines * Rnd()) + 1
    
       ' Insert the random quote
    
       Item.HTMLBody = Replace(Item.HTMLBody, SearchString, "<img src=""http://servidor/" & lines(randLine) & " ""/>")
    
       MsgBox ("<img src=""http://servidor/" & lines(randLine) & " ""/>")
    
       Item.HTMLBody = Replace(Item.HTMLBody, "%Random_Num%", "<img src=""http://servidor/" & randLine & " ""/>")
    
       MsgBox ("<img src=""http://servidor/" & randLine & " ""/>")
    
      End If
    
     End If
    
    End Sub
    
    
    
    Function FileOrDirExists(PathName As String)
    
     Dim iTemp As Integer
    
    
    
     On Error Resume Next
    
     iTemp = GetAttr(PathName)
    
    
    
     Select Case Err.Number
    
     Case Is = 0
    
      FileOrDirExists = True
    
      MsgBox ("Passo4")
    
     Case Else
    
      FileOrDirExists = False
    
      MsgBox ("Passo5")
    
     End Select
    
    
    
     On Error GoTo 0
    
    End Function
    
    
    
    


    segue o codigo todo...

    Lembrando nao funcionou em 2007...:(

    Abraços...

     


    Edson Matias Fagundes Junior (Nioks)
    terça-feira, 2 de agosto de 2011 20:32
  • Edson,

    pelos meus testes iniciais parece corresponder ao que preciso.

    Pelo que entendi as imagens ficam publicadas na net e no ficheiro de texto está a lista dos ficheiros.

    Amanhã farei testes mais profundos e irei postar.

    Vou tentar adaptar.

    Mas valeu muiitoo, acho que muita gente irá gostar.


    Cláudio Gonçalves
    terça-feira, 2 de agosto de 2011 20:54
  • Fico Feliz por ajudar nao equece de colocar o nome dos arquivos completo imagem.jpg no txt ok.

     

    Abraços...

     


    Edson Matias Fagundes Junior (Nioks)
    terça-feira, 2 de agosto de 2011 21:00