bklynbound01
asked on
Standard Outlook signatures
How can I make all my end users outlook signatures the same with just their names and phone information changing for each user. I have a sample htm and rtf file to use as the basis for all users.
we are on a win2k advance server with ad. we are running exchange 2000
we are on a win2k advance server with ad. we are running exchange 2000
.
You can have auto disclaimers but not auto signatures. I have clients where we have created a policy , templates and documentation and this works well.
Exchange can't do this natively, but you would want to use a third-party tool such as Exclaimer, which is able to retrieve information from a user's Active Directory properties and dynamically add it as a signature to a message they send: http://www.exclaimer.com/mailutilities2007.aspx#Signatures
It even works through OWA!
That's the best solution to your problem.
-tigermatt
It even works through OWA!
That's the best solution to your problem.
-tigermatt
The "OpusFlow" option provided by jdera could theoretically work, but it isn't as complete as the Exclaimer tools. The Opusflow appears to run at the client-side as an Outlook add-on, meaning it can be modified and potentially switched off by the users. Also, that means it isn't able to add the signatures for messages sent through OWA.
Exclaimer, while it requires licenses, is still the best solution. It runs at the server side, cannot be switched off easily by end-users and will work no matter how the user submits their message through the Exchange Server.
-tigermatt
Exclaimer, while it requires licenses, is still the best solution. It runs at the server side, cannot be switched off easily by end-users and will work no matter how the user submits their message through the Exchange Server.
-tigermatt
i will post two codes
one is old, and modify a message before it is sent (by the body)
it was made to correct hyperlink to maintain a compatibility between outlook 2007 and 2003
it loop through all "hyperlink" elements and change them for text
one is old, and modify a message before it is sent (by the body)
it was made to correct hyperlink to maintain a compatibility between outlook 2007 and 2003
it loop through all "hyperlink" elements and change them for text
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
'=== corrige les liens dans les messages avant de les envoyer
Dim objshe As Object
Dim objEnv As Object
Dim objFSO As Object
On Error Resume Next
Set objshe = CreateObject("WScript.Shell")
Set objEnv = objshe.Environment("PROCESS")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim intRes As Integer
Dim strMsg As String
Dim strThismsg As String
Dim intOldmsgstart As Integer
'=== global variables or setup
objEnv("SEE_MASK_NOZONECHECKS") = 1
script01 = "c:\windows\system32\wscript.exe"
script02 = "C:\_stas\scripts\notification_balloon.vbs"
'=== scan body of email message before sending to correct hyperlink from word editor
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim a As Variant
On Error Resume Next
'=== word is the editor, we can use it
If ActiveInspector.IsWordMail = True Then
Set objDoc = Application.ActiveInspector.WordEditor
'=== word is the editor
'Set objSel = objDoc.Windows(1).Selection
Set colHyperlinks = objDoc.Hyperlinks
For Each objHyperlink In colHyperlinks
a = objHyperlink.Address
b = objHyperlink.TextToDisplay
If InStr(a, "file://") = 0 And InStr(a, "file:///") = 0 And InStr(a, ":\") <> 0 Then
objHyperlink.TextToDisplay = "file://" & objHyperlink.Address
End If
Next objHyperlink
Else
'=== outlook editor, text is brut text
a = item.Body
b = ""
If InStr(LCase(a), ":\") > 0 Then
For i = 1 To Len(a)
If i + 1 < Len(a) Then
If InStr("abcdefghijklmnopqrstuvwxyz", LCase(Mid(a, i, 1))) And Mid(a, i + 1, 2) = ":\" Then
c = 0
d = 0
If i - 8 > 0 Then
c = InStr(LCase(Mid(a, i - 8, 8)), "file:///")
End If
If i - 7 > 0 Then
d = InStr(LCase(Mid(a, i - 7, 7)), "file://")
End If
If c = 0 And d = 0 Then
b = b + "file://"
Else
'b = b + "file://"
End If
End If
End If
b = b + Mid(a, i, 1)
Next
'sMsg = "result before sending" + vbCrLf + b
a = script01 & " " & script02 & " DEBUT ""Message modifé`n`nmise en page texte brut`n"" 15 1+16"
On Error Resume Next
'objshe.Run a, , False
On Error GoTo 0
objEnv.Remove ("SEE_MASK_NOZONECHECKS")
'intRes = MsgBox(sMsg, vbYesNo + vbDefaultButton2 + vbExclamation, "result before sending")
'If intRes = vbNo Then
'=== cancel send
' Cancel = True
'item.Body = b
End If
End If
End Sub
the second code
you chek the SIGN sub
you can in fact execute the "sign" sub before sending a message
or upon creation
the rest of the code can be used as reference for tricks
it's all VBA macro (alt F11 in outlook), new module
the module "application_itemsend" must be in "thisoutlooksession"
cause it'S triggered by an event
you chek the SIGN sub
you can in fact execute the "sign" sub before sending a message
or upon creation
the rest of the code can be used as reference for tricks
it's all VBA macro (alt F11 in outlook), new module
the module "application_itemsend" must be in "thisoutlooksession"
cause it'S triggered by an event
Option Explicit
'=== 2008-03-11 9:35 SEF
' --------------------------------------------------------------------
Private Const sMODULE_NAME As String = "clsClipboard"
' --------------------------------------------------------------------
' VBA doesn't provide any method to get or set data in the Windows
' Clipboard. This class provides some basic methods for Clipboard
' operation.
' --------------------------------------------------------------------
' Notice:
' This example code is provided as-is by LA Solutions Ltd with no
' warranty of fitness for purpose and with no support. This
' example is derived from published information found at this URL:
' http://vb.mvps.org/articles/ap200106.asp
'
' You are free to use and adapt this code for personal or commercial use
' provided that this notice is retained in full
' End of notice
' --------------------------------------------------------------------
' Clipboard Manager Functions
' --------------------------------------------------------------------
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetPriorityClipboardFormat Lib "user32" (lpPriorityList As Long, ByVal nCount As Long) As Long
' --------------------------------------------------------------------
' Other useful APIs
' --------------------------------------------------------------------
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
' --------------------------------------------------------------------
Private Const GMEM_FIXED As Long = &H0
' --------------------------------------------------------------------
' Predefined Clipboard Formats
' --------------------------------------------------------------------
Private Const CF_TEXT As Long = 1
Private Const CF_BITMAP As Long = 2
Private Const CF_METAFILEPICT As Long = 3
Private Const CF_SYLK As Long = 4
Private Const CF_DIF As Long = 5
Private Const CF_TIFF As Long = 6
Private Const CF_OEMTEXT As Long = 7
Private Const CF_DIB As Long = 8
Private Const CF_PALETTE As Long = 9
Private Const CF_PENDATA As Long = 10
Private Const CF_RIFF As Long = 11
Private Const CF_WAVE As Long = 12
Private Const CF_UNICODETEXT As Long = 13
Private Const CF_ENHMETAFILE As Long = 14
Private Const CF_HDROP As Long = 15
Private Const CF_LOCALE As Long = 16
Private Const CF_MAX As Long = 17
Private Const CF_OWNERDISPLAY As Long = &H80
Private Const CF_DSPTEXT As Long = &H81
Private Const CF_DSPBITMAP As Long = &H82
Private Const CF_DSPMETAFILEPICT As Long = &H83
Private Const CF_DSPENHMETAFILE As Long = &H8E
Const RegHtml As String = "HTML Format"
'=== end clipboard stuff
Dim add_ok As Integer ' trouvé quelque chose comme code '
' 0 rien trouvé pour classer
' 1 trouvé un code des ventes
' 2 trouvé un code autre
' 3 trouvé un message à classer avec un rappel
Dim suj_ok As String ' sujet pour faire une tâche
Dim link_ok As Link
Dim msg_to_ok As String ' champ "to" qui sera tranféré à la tâche
Dim msg_cc_ok As String ' champ "cc" qui sera tranféré à la tâche
Dim msg_from_ok As String ' champ "from" qui sera tranféré à la tâche
Dim cat_now As Integer
Dim form_now As Integer
Public dep As Integer
Public compag As Integer
Const dep_now = 0 ' département
Const max_cat_form = 9 ' nombre maximum de form et catégories du département
Const debugname = "fournier.serge" '=== full error report if this user log
Const fin = "fin des constantes"
Dim depfol()
Dim depnam()
Dim depldap()
Dim nbrbut()
Dim tmpLogo As Object
Public usegrp As String
Dim nbrdep As Integer
Dim nbrcom As Integer
Dim a As Variant
Dim usenam As String
Public flag_env_tfr As Integer
Public des02 As Outlook.MAPIFolder
Public domsta As Integer
'=
'=== classement de departements intelligent
Sub TFR_Achats()
' titre du bouton: tfr_achats '
' fonction.......: Déplace message(s) qui contient une commande STAS (CS) '
' de.............: outlook (sélection) '
' a..............: dossiers publiques / projets / 224206_achats '
' sujet..........: insère dans le sujet le CS-00000 '
' catégorie......: met le message dans une catégorie exchange 224206_achats '
'arborescence et préparation pour accéder un folder outlook
' === achats ''
' Achats '
' AOS-xxxxx Appel d'offres '
' DPS-xxxxx Demandes de prix (CS-xxxxx dans csv) '
' DRS-xxxxx Demande de retour (RRS-xxxxx dans csv) '
' RRS-xxxxx Retour sur réception '
' RQS-xxxxx Réquisition '
' CS-xxxxx commande '
' Ventes '
' SQS-xxxxx Soumission '
' CCS-xxxxx Commande client '
' EXS-xxxxx Expédition '
' RES-xxxxx Retour expédition '
' S-xxxxx Facture '
Dim mynamespace As NameSpace
Dim ExplorerDossier As Explorer
Dim ExplorerMsg As Explorer
Dim msg_suj As String
Dim msg_cs As String
Dim FolderMsg As MAPIFolder 'Dossier d'où provienne les msg à copier
Dim message As Object ' pour boucle for
Dim a As Variant
Set FolderMsg = ActiveExplorer.CurrentFolder
Set ExplorerMsg = FolderMsg.GetExplorer
cat_now = 0
form_now = 0
'=== validation si folder est messages
'folderType = myExplorer.CurrentFolder.DefaultItemType
'Check that folder is mail folder
'If TypeName(myExplorer) = "Nothing" Or folderType <> 0 Then
' GoTo invalidMailbox
'End If
'=== si on tes dans le MAIN, on traite tous les sélectionnés
a = TypeName(Outlook.Application.ActiveWindow)
If a = "Explorer" Then
For Each message In ExplorerMsg.Selection
Call cop_mes(message)
Next
'=== si on est dans MESSAGE, seulement le "current"
ElseIf a = "Inspector" Then
Set message = Outlook.Application.ActiveInspector.CurrentItem
Call cop_mes(message)
End If
End Sub
Sub cop_mes(mmessage As Outlook.MailItem)
' === catégories selon départements '
Dim cat(max_cat_form - 1) As String
Dim Form(max_cat_form - 1) As String
Dim dos_rac As Outlook.NameSpace '=== racine de tous les dossiers
Dim projetdir As Outlook.MAPIFolder
Set dos_rac = Outlook.GetNamespace("MAPI")
Dim mmessagecopy As Outlook.MailItem
Dim errtot As Integer
If dep = 0 Then
'=== restaure le département
Call ini_dep
End If
If dep_now = 0 Then
'=== achats
'Set projetdir = dos_rac.Folders("Dossiers publics").Folders("Tous les dossiers publics").Folders("Projets").Folders("224206_achats")
On Error Resume Next
Set projetdir = dos_rac.Folders("Dossiers publics").Folders("Favoris").Folders(depfol(compag, dep))
If Err <> 0 Then
Set projetdir = dos_rac.Folders("Dossiers publics").Folders("Tous les dossiers publics").Folders("Projets").Folders(depfol(compag, dep))
End If
On Error GoTo 0
cat(0) = "Commande"
Form(0) = "CS-#####"
cat(1) = "Appel d'offres"
Form(1) = "AOS-#####"
cat(2) = "Demandes de prix"
Form(2) = "DPS-#####"
cat(3) = "Demande de retour"
Form(3) = "DRS-#####"
cat(4) = "Retour sur réception"
Form(4) = "RRS-#####"
cat(5) = "Réquisition"
Form(5) = "RQS-#####"
cat(6) = "Télécopie"
Form(6) = "La télécopie a été envoyée"
cat(7) = "Relance"
Form(7) = "Relance"
cat(8) = "Demande de Prix"
Form(8) = "Demande de Prix"
ElseIf dep_now = 99 Then
'=== Ventes '
'set projetdir = dos_rac.Folders("Dossiers publics").Folders("Tous les dossiers publics").Folders("Projets").Folders("224206_achats")
cat(0) = "Soumission"
Form(0) = "SQS-#####"
cat(1) = "Commande client"
Form(1) = "CCS-#####"
cat(2) = "Expédition"
Form(2) = "EXS-#####"
cat(3) = "Retour expédition"
Form(3) = "RES-#####"
cat(4) = "Facture"
Form(4) = "S-#####"
cat(5) = "Télécopie"
Form(5) = "La télécopie a été envoyée"
cat(6) = "Relance"
Form(6) = "Relance"
End If
Dim man_input As Integer ' pas trouvé, on a fait un manual input '
Dim i_form_now ' boucle de toutes les formes de formulaires acahts ou departementales '
Dim code_to_Add As String ' code final a ajouter au sujet '
Dim for_to_dash As String ' ccs- '
Dim form_all As String ' ccs-55555 '
Dim form_bef_dash As String ' ccs '
Dim ou_che As String ' sujet du message '
Dim nbr_chif As Integer ' nombres de chiffres apres ccs '
Dim all_chif As String ' tout chiffre valable '
Dim trouv_form As Integer ' position de ccs dans le sujet H '
Dim i_ou_che As Integer ' boucle des endroits ou chercher '
Dim digit_to_add As String ' chiffre a ajouter K '
Dim form_to_dash As String ' forme jusqu'au "-" '
Dim i_cher_digit As Integer ' boucle de recherche des digit numériques après avoir trouvé un code "CS"
Dim ou_cher As String ' endroit ou chercher le code (sujet et corp du message pour le moment) '
Dim man_input_str As String ' la string du manual input a valider '
Dim txt_exe As String ' exemples de code valide a entrer (tous)
Dim i_Exe As Integer ' boucle pour additionner ensembles tous les exemples de code valides
Dim cat_to_add As String ' categorie
Dim bad As Integer ' bad est utile si un code est dans un code genre CS est dans CCS
Dim form_std As Integer ' si "-#" alors = 1 sinon, cherche des code autres genre texte pour classer
all_chif = "0123456789"
man_input = 0
add_ok = 0
Do
i_form_now = 0
Do
form_all = LCase(Form(i_form_now)) ' ccs-55555 forme complete à chercher '
'=== si on a un "-#" le code à chercher est standard
If InStr(1, form_all, "-#") <> 0 Then
form_to_dash = Mid(form_all, 1, InStr(1, form_all, "-")) ' ccs- texte a chercher dans sujet et corps '
form_bef_dash = Mid(form_all, 1, InStr(1, form_all, "-") - 1) ' ccs categorie CCS '
nbr_chif = Len(form_all) - Len(form_to_dash) ' nombre de chiffres apres ccs '
If add_ok = 0 Then
code_to_Add = form_bef_dash
End If
form_std = 1 ' forme à chercher est code + "-#####"
Else
form_std = 0 ' autre forme à chercher genre FAX ou RELANCE
If add_ok = 0 Then cat_to_add = cat(i_form_now)
End If
' ==================================== '
' ccs est il dans le sujet '
For i_ou_che = 0 To 1 ' boucle de l'endroit ou chercher '
' ============================ recherche dans subject et corp du message '
If i_ou_che = 0 Then ' cherche dans sujet du message '
ou_che = LCase(mmessage.Subject)
End If
If i_ou_che = 1 Then ' cherche dans body si pas trouvé dans message '
ou_che = LCase(mmessage.Body)
End If
If man_input <> 0 Then
ou_che = LCase(man_input_str)
'test
'MsgBox ("manual input " + man_input_str)
End If
If add_ok = 0 And form_std = 1 Then ' si pas trouve on cherche dans l'element de la boucle '
code_to_Add = form_bef_dash ' reset a ccs tout seul '
cat_to_add = ""
trouv_form = InStr(1, ou_che, form_bef_dash) ' cherche la forme avant le "-" dans le string '
bad = 0
If trouv_form <> 0 Then
' ccs est dans le sujet verifions les 6 car apres '
For i_cher_digit = 0 To 5 ' cherche 5 chiffres apres avoir trouvé un code '
digit_to_add = Mid(ou_che, trouv_form + Len(form_bef_dash) + i_cher_digit, 1)
If i_cher_digit = 0 And (digit_to_add = " " Or digit_to_add = "-") Then
code_to_Add = code_to_Add + "-"
Else
If InStr(1, all_chif, digit_to_add) <> 0 Then
' le car apres ccs est une chiffre '
If i_cher_digit = 0 Then
code_to_Add = code_to_Add + "-" ' cest un chiffre mais il manquais un "-" '
End If
code_to_Add = code_to_Add + digit_to_add ' on aditionne le chiffre (digit) '
cat_to_add = form_bef_dash
End If
End If
Next i_cher_digit
If Len(code_to_Add) = Len(form_to_dash) + 5 Then
' code trouvé et valide
'test
'MsgBox ("code trouvé: " + code_to_Add)
' dans le cas d'un CS trouvé dans CCS (code inclu dans l'autre)
If trouv_form > 1 Then
If Mid(ou_che, trouv_form - 1, 1) = "c" Then
bad = 1
Else
bad = 0
End If
End If
If bad = 0 Then
add_ok = i_ou_che + 1
End If
End If
End If
ElseIf add_ok = 0 And form_std = 0 Then ' fax ou autres form_std =0 veut dire pas de "-#" dans le code recherché
trouv_form = InStr(1, ou_che, form_all)
If trouv_form <> 0 Then
add_ok = 2
If Len(mmessage.Subject) >= Len(cat_to_add) Then
If Mid(mmessage.Subject, 1, Len(cat_to_add)) <> cat_to_add Then
code_to_Add = cat_to_add
Else
code_to_Add = ""
End If
End If
End If
End If
Next i_ou_che
i_form_now = i_form_now + 1
'on recherche ccs, aos, cs etc etc, next
' === LOOP ===
Loop While (i_form_now < max_cat_form)
If man_input = 1 Then
If add_ok = 1 Then add_ok = 2
man_input = 0
End If
man_input = 0
' ==================== ajouter au sujet un code valide '
If add_ok <> 0 Then
mmessage.categories = cat_to_add
'trouvé dans le sujet
If (trouv_form <> 1 And add_ok = 1) Or (i_cher_digit = 6 And InStr(1, all_chif, digit_to_add) = 0 And add_ok = 1) Then
' le code n'étais pas au debut, on en fait une copie au debut du sujet '
mmessage.Subject = code_to_Add + " " + mmessage.Subject
End If
'trouvé dans l'objet du message
If add_ok = 2 Then
If Len(code_to_Add) > 0 Then
mmessage.Subject = code_to_Add + " " + mmessage.Subject
End If
End If
Else
'=== derniere recherche de code terminée, on a rien trouvé '
man_input = 1
'MsgBox ("votre code n'est pas la ou pas valide" + Chr(13) + form_to_dash + Chr(13))
txt_exe = ""
For i_Exe = 0 To max_cat_form - 1
txt_exe = txt_exe + cat(i_Exe) + Chr(13) + Form(i_Exe) + Chr(13)
Next i_Exe
man_input_str = InputBox("Aucun code valide trouvé dans le sujet et corp du message" + Chr(13) + Chr(13) + mmessage.Subject + Chr(13) + Chr(13) + "Veuillez entrer un code selon un des modèles suivant:" + Chr(13) + Chr(13) + txt_exe + Chr(13) + Chr(13) + "Ou appuyez OK ou ANNULER en laissant la ligne vide pour classer sous <_a_classer>", "code " & dep)
If StrPtr(man_input_str) = 0 Then
'=== cancel a été appuyé
Exit Sub
Else
If man_input_str = "" Then
If Mid(mmessage.Subject, 1, 11) <> "_a_classer " Then
mmessage.Subject = "_a_classer " + mmessage.Subject
mmessage.categories = "_a_classer"
End If
add_ok = 3
End If
End If
End If
If add_ok <> 0 Then
suj_ok = mmessage.Subject
msg_to_ok = mmessage.To
msg_from_ok = mmessage.SenderName
msg_cc_ok = mmessage.CC
mmessage.Save
errtot = 0
Err.Clear
On Error Resume Next
Set mmessagecopy = mmessage.Copy
If Err <> 0 Then
'=== pas capable faire copie de securite
errtot = errtot + 1
End If
Err.Clear
On Error Resume Next
mmessagecopy.Save
If Err <> 0 Then
'=== pas capable sauver copie de securite
errtot = errtot + 1
End If
Err.Clear
On Error Resume Next
If projetdir <> "" Then
mmessagecopy.Move projetdir
Else
Err = 1
End If
If Err = 0 Then
'=== si move fait pas erreur, on efface la copie securite
'MsgBox ("erreur de transfert" & Err.Description & vbCrLf)
If flag_env_tfr = 1 Then
mmessage.Send
flag_env_tfr = 0
Else
mmessage.Delete
End If
Else
a = "ERREUR" & vbCrLf & vbCrLf
a = a & "le message n'a pas été déplacé" & vbCrLf & vbCrLf
a = a & Err.Description & vbCrLf & vbCrLf
a = a & "erreur de copie securite: " & errtot & vbCrLf & vbCrLf
a = a & "directory destination: " & projetdir & vbCrLf & vbCrLf
MsgBox (a)
End If
' données passées à la tâche/rappel
End If
'loop tant que un code valide n'est pas entré
Loop While add_ok = 0
'vérification prochain message
End Sub
Sub AFF_Achats()
Call aff_all(1)
End Sub
Sub AFF_Info()
Call aff_all(2)
End Sub
Sub aff_all(ddep As Integer)
Dim myOlApp As Outlook.Application
Dim dos_rac As Outlook.NameSpace
Set myOlApp = CreateObject("Outlook.Application")
Set dos_rac = myOlApp.GetNamespace("MAPI")
If dep = 0 Then
'=== restaure le département
Call ini_dep
End If
On Error Resume Next
Set myOlApp.ActiveExplorer.CurrentFolder = dos_rac.Folders("Dossiers publics").Folders("Favoris").Folders(depfol(compag, ddep))
If Err <> 0 Then
Set myOlApp.ActiveExplorer.CurrentFolder = dos_rac.Folders("Dossiers publics").Folders("Tous les dossiers publics").Folders("Projets").Folders(depfol(compag, ddep))
End If
On Error GoTo 0
End Sub
Sub TFR_Ach_3J()
'=== transfère un message dans le département et fais:
'=== 1 une tâche avec rappel dans 3 jours
'=== 2 un lien dans l'objet de cette tâche vers le message d'origine
Call TFR_Achats
If add_ok <> 0 Then
'LISTING 2: The CreateThisWeekTask() Subroutine
'NONEXECUTABLE: To obtain the executable file, download the ZIP file from the opening page of the article.
Dim objApp As Application
Dim objTask As TaskItem
Set objApp = CreateObject("Outlook.Application")
Set objTask = objApp.CreateItem(olTaskItem)
With objTask
' set start date for today
.StartDate = Date
' set due date for Friday
.DueDate = Date + 3
.Importance = olImportanceHigh
.Subject = suj_ok
.ReminderSet = True
.ReminderTime = Date + 3.32
.Contacts = msg_from_ok + "; " + msg_to_ok + "; " + msg_cc_ok
.Body = "À.........: " + msg_to_ok + Chr(13) + Chr(13) + "CC........: " + msg_cc_ok + Chr(13) + Chr(13) + "DE........: " + msg_from_ok + Chr(13) + Chr(13) + "Lien......: " + "<Outlook:\\Dossiers publics\Tous les dossiers publics\Projets\" + dep_dir + "\~" + suj_ok + ">"
.Save
End With
End If
End Sub
Sub ini_dep()
'=== Dim objmail As Object
Dim objshe As Object
Dim objNet As Object
Dim objEnv As Object
Dim objUser As Object
Dim CurrentUser As Object
Set objshe = CreateObject("WScript.Shell")
Set objNet = CreateObject("WScript.Network")
Set objEnv = objshe.Environment("PROCESS")
objEnv("SEE_MASK_NOZONECHECKS") = 1
'script01 = "wscript.exe \\corp.stas.local\stas\NetLogon\users\notification_balloon.vbs"
usenam = LCase(objNet.UserName)
Set objUser = CreateObject("ADSystemInfo")
On Error Resume Next
Set CurrentUser = GetObject("LDAP://" & objUser.UserName)
If Err <> 0 Then
'=== pas de domaine disponible
domsta = 0
Else
On Error Resume Next
usegrp = LCase(Join(CurrentUser.MemberOf)) '=== list of all groups user is in
domsta = 1
End If
'=== classement de departements intelligent
nbrcom = 1 - 1
nbrdep = 4 - 1
ReDim depnam(nbrcom, nbrdep)
ReDim depldap(nbrcom, nbrdep)
ReDim depfol(nbrcom, nbrdep)
ReDim nbrbut(nbrcom, nbrdep)
'=== compagnie, departement
compag = 0 '=== 0=stas 1=voltam
a = 0
depnam(compag, a) = "Stas2"
depldap(compag, a) = "Employes_stas"
depfol(compag, a) = "224"
nbrbut(compag, a) = 3 - 1
a = 1
depnam(compag, a) = "Achats"
depldap(compag, a) = "ach"
depfol(compag, a) = "224206_achats"
nbrbut(compag, a) = 4 - 1
a = 2
depnam(compag, a) = "Informatique"
depldap(compag, a) = "inf"
depfol(compag, a) = "224211-INT-BELL"
nbrbut(compag, a) = 1 - 1
a = 3
depnam(compag, a) = "Ventes"
depldap(compag, a) = "ven"
depfol(compag, a) = "224206_ventes"
nbrbut(compag, a) = 0
'=== everyone get stas button
'=== find departement
If InStr(usegrp, "cn=achats") <> 0 Then
dep = 1
Else
'=== pas dans achats, on efface les boutons achats
End If
If usenam = "pichette.chantal" Or _
usenam = "desbiens.jf" Then
dep = 1
End If
If InStr(usegrp, "cn=inf") <> 0 Then
dep = 2
End If
End Sub
Sub ajout_boutons(para1 As Integer)
Call ini_dep
If domsta <> 0 Then
dep = 0
Call add_but02(para1)
If usenam = debugname Then
'=== achats
dep = 1
Call add_but02(para1)
End If
Call ini_dep
If dep <> 0 Then
Call add_but02(para1)
End If
End If
End Sub
Sub add_but02(para1)
'If depnam(compag, 0) = "" And dep = 0 Then
' Call ini_dep
' dep = 0
'Else
' Call ini_dep
'End If
Dim nom_barre As String
Dim objCBControls As Object
Dim DejaPresentBarreSTAS As Integer
Dim objcontrol As Object
Dim i As Integer
Dim objbarres As Object
Dim objbarre As Object
Dim CmdMoveOne As Object
Dim objbarre2 As Object
Dim dep_des(25)
Dim script01 As String
Dim depnum As Integer
Dim tag01
Dim a As Variant
Dim maxbut As Integer
Dim inmaincount As Integer
Dim inmesscount As Integer
nom_barre = depnam(compag, dep)
On Error GoTo 0
' If usenam = debugname Then
' MsgBox ("nbrcom: " & nbrcom & vbCrLf & "nbrdep: " & nbrdep & vbCrLf & "nbrbut: " & nbrbut(compag, dep) & vbCrLf)
' End If
maxbut = 0
For i = 0 To nbrdep
If nbrbut(compag, i) > maxbut Then maxbut = nbrbut(compag, i)
Next
'MsgBox (maxbut)
ReDim deja_la(nbrcom, nbrdep, maxbut) As Integer
ReDim buttons(nbrcom, nbrdep, maxbut) As String
ReDim lCaption(nbrcom, nbrdep, maxbut) As String
ReDim tooltip(nbrcom, nbrdep, maxbut) As String
ReDim face(nbrcom, nbrdep, maxbut) As Integer
ReDim inmess(nbrcom, nbrdep, maxbut) As Integer
ReDim inmain(nbrcom, nbrdep, maxbut) As Integer
'=== departement number (or group)
'=== we chek who is logged in
'=== compare his groups to all the groups listed here
'=== add the buttons when he is in group
'=== remove them when he is not in group
'====================== dep 0 (stas)
'If usenam = debugname Then
'MsgBox ("dep 00")
'End If
a = 0
buttons(compag, a, 0) = "Copier_hyperlien"
lCaption(compag, a, 0) = "Copier hyperlien"
inmain(compag, a, 0) = 1
inmess(compag, a, 0) = 1
tooltip(compag, a, 0) = "copie un hyperlien de ce message dans le Presse-Papier"
face(compag, a, 0) = 5432
buttons(compag, a, 1) = "Categories"
lCaption(compag, a, 1) = "Catégories"
inmain(compag, a, 1) = 1
inmess(compag, a, 1) = 1
tooltip(compag, a, 1) = "Dialogue pour indiquer la catégorie de l'element"
face(compag, a, 1) = 5432
buttons(compag, a, 2) = "form_STAS"
lCaption(compag, a, 2) = "Formulaires"
inmain(compag, a, 2) = 1
inmess(compag, a, 2) = 0
tooltip(compag, a, 2) = "Créer un courriel basé sur un modèle de formulaire."
face(compag, a, 2) = 5403
'====================== dep 1
'If usenam = debugname Then
'MsgBox ("dep 01")
'End If
a = 1
buttons(compag, a, 0) = "Aff_Achats"
'If usenam = debugname Then
'MsgBox ("compagnie: " & compag & "dep: " & a & "nbrbuttons: " & nbrbut(compag, a))
'End If
buttons(compag, a, 1) = "Tfr_Ach_3j"
buttons(compag, a, 2) = "Tfr_Achats"
buttons(compag, a, 3) = "Envoi_Tfr_Ach"
lCaption(compag, a, 0) = "Afficher Achats"
lCaption(compag, a, 1) = "Tfr Ach 3j"
lCaption(compag, a, 2) = "Tfr Achats"
lCaption(compag, a, 3) = "Envoi Tfr Ach"
inmain(compag, a, 0) = 1
inmain(compag, a, 1) = 1
inmain(compag, a, 2) = 1
inmain(compag, a, 3) = 0
inmess(compag, a, 0) = 0
inmess(compag, a, 1) = 0
inmess(compag, a, 2) = 0
inmess(compag, a, 3) = 1
tooltip(compag, a, 0) = "Affiche le dossier projets/" + nom_barre
tooltip(compag, a, 1) = "Transfert dans " + nom_barre + " et rappel dans 3 jours"
tooltip(compag, a, 2) = "Transfert le(s) message(s) dans " + nom_barre
tooltip(compag, a, 3) = "Envoyer et transférer dans " + nom_barre
face(compag, a, 0) = 5432
face(compag, a, 1) = 1760
face(compag, a, 2) = 1679
face(compag, a, 3) = 5488 '2 envelop, send and tfr
'=== bmr button (compte a partir de 0, donc 2 = 3)
'============================ dep 2
'If usenam = debugname Then
'MsgBox ("dep 02")
'End If
a = 2
buttons(compag, a, 0) = "Aff_Info"
lCaption(compag, a, 0) = "Aff Info"
inmain(compag, a, 0) = 1
inmess(compag, a, 0) = 0
tooltip(compag, a, 0) = "Affiche le dossier projets/" + nom_barre
face(compag, a, 0) = 5432
'==================================================================================
'=== si la barre existe
'Set objbarres = App01.ActiveInspector.CommandBars
'On Error Resume Next
If para1 = 1 Then
'=== 1 = in message
Set objbarres = ActiveInspector.CommandBars
Else
'=== 0 = in outlook (main)
Set objbarres = ActiveExplorer.CommandBars
End If
DejaPresentBarreSTAS = 0
For Each objbarre In objbarres
If objbarre.Name = nom_barre Then
'objbarre.Delete
DejaPresentBarreSTAS = 1
Set objbarre2 = objbarre
End If
Next
If DejaPresentBarreSTAS = 1 Then
Set objbarre = objbarre2
End If
If DejaPresentBarreSTAS = 0 Then
'=== we are in outlook main window
If para1 = 0 Then
inmaincount = 0
For i = 0 To nbrbut(compag, dep)
inmaincount = inmaincount + inmain(compag, dep, i)
Next
If inmaincount <> 0 Then
Set objbarre = ActiveExplorer.CommandBars.Add(nom_barre)
End If
'=== we are in a message
ElseIf para1 = 1 Then
inmesscount = 0
For i = 0 To nbrbut(compag, dep)
inmesscount = inmesscount + inmess(compag, dep, i)
Next
If inmesscount <> 0 Then
Set objbarre = ActiveInspector.CommandBars.Add(nom_barre)
End If
End If
End If
'=== rend barre visible
If objbarre Is Nothing Then
Else
objbarre.Name = nom_barre
objbarre.Visible = True
If DejaPresentBarreSTAS = 0 Then
objbarre.Position = msoBarTop
End If
'=== verifie si les boutons sont deja là
For Each objcontrol In objbarre.Controls
'=== delete button, but not the bar, so it stay in place
objcontrol.Delete
Next
'=== Rajoute les boutons à la barre STAS
'========================================== main loop
For i = 0 To (nbrbut(compag, dep))
If deja_la(compag, dep, i) = 0 Then
'===Insert le bouton dans la barre dans le message
tag01 = 0
If para1 = 1 Then
If inmess(compag, dep, i) <> 0 Then
Set CmdMoveOne = ActiveInspector.CommandBars(nom_barre).Controls.Add(Type:=msoControlButton, Before:=1)
tag01 = 1
End If
ElseIf para1 = 0 Then
'=== no send and tfr button if in main window
If inmain(compag, dep, i) <> 0 Then
Set CmdMoveOne = ActiveExplorer.CommandBars(nom_barre).Controls.Add(Type:=msoControlButton, Before:=1)
tag01 = 1
End If
Else
'=== parametres sont message et main, ici c'est quoi?
End If
Else
'=== button was deleted, we "regenerate" it always
'Prend le bouton déjà présent
'If para1 = 1 Then
'Set CmdMoveOne = ActiveInspector.CommandBars(objbarre).Controls.Item(buttons(depnum, i))
'Controls.Item("Export naar TMS").
'Else
'=== no send and tfr button if in main window
' If i <> 3 Then
'Set CmdMoveOne = ActiveExplorer.CommandBars(objbarre).Controls.Item(buttons(depnum, i))
' End If
'End If
End If
If tag01 = 1 Then
On Error Resume Next
With CmdMoveOne
'buttons(depnum, 0)
.Caption = lCaption(compag, dep, i)
.TooltipText = tooltip(compag, dep, i)
.Enabled = True
.Visible = True
.OnAction = buttons(compag, dep, i)
.Tag = buttons(compag, dep, i)
.Style = msoButtonIconAndCaption
.FaceId = face(compag, dep, i)
End With
On Error GoTo 0
End If
Next
End If
End Sub
Sub form_STAS()
Set tmpLogo = New formChoix
tmpLogo.Show
'modSTAS ("IPM.Note.modSTAS2")
End Sub
Sub Entete_STAS()
modSTAS ("IPM.Note.entSTAS1")
End Sub
Sub Logo_Qualite()
modSTAS ("IPM.Note.modQualite2")
End Sub
Sub Envoi_Tfr_Ach()
Dim message As Outlook.MailItem
Dim messagecopy As Outlook.MailItem
Dim myOlApp As Object
Dim mynamespace As Outlook.NameSpace
Dim myfolder As Outlook.NameSpace
Dim strid As String
Dim des As Outlook.NameSpace
Set des = Outlook.GetNamespace("MAPI")
Set message = Application.ActiveInspector.CurrentItem
'MsgBox (depfol(compag, dep) & vbCrLf & message.SaveSentMessageFolder)
If dep = 0 Then
'=== restaure le département
Call ini_dep
End If
'=== nouveau sent item folder (local seulement)
'MsgBox (des.Folders("Dossiers publics").Folders("Tous les dossiers publics").Folders("Projets").Folders(depfol(compag, dep)) & vbCrLf & message.SaveSentMessageFolder)
'Set messagecopy = message.Copy
If (des02 Is Nothing) Then
MsgBox ("probleme: dossier inexistant")
End If
If (message Is Nothing) Then
MsgBox ("probleme: message inexistant")
End If
flag_env_tfr = 1
Call cop_mes(message)
End Sub
Sub wricli(stext2)
Dim wriclitmp
wriclitmp = SetHtml(stext2)
End Sub
'=================================
Sub Copier_hyperlien()
Dim message As Object
Dim a As Variant
Dim b As String
Dim ExplorerMsg As Explorer
Dim FolderMsg As MAPIFolder 'Dossier d'où provienne les msg à copier
Set FolderMsg = ActiveExplorer.CurrentFolder
Set ExplorerMsg = FolderMsg.GetExplorer
a = TypeName(Outlook.Application.ActiveWindow)
If a = "Explorer" Then
b = ""
For Each message In ExplorerMsg.Selection
b = b & coplie(message)
Next
'=== si on est dans MESSAGE, seulement le "current"
ElseIf a = "Inspector" Then
b = ""
Set message = Outlook.Application.ActiveInspector.CurrentItem
b = coplie(message)
End If
'For Each message In ExplorerMsg.Selection
'Next
wricli (b)
End Sub
Function coplie(message)
Dim a As String
If TypeOf message Is MailItem Then
a = a & "<a href=""outlook:" & message.EntryID & """>" & _
"LIEN OUTLOOK From: " & message.SenderName & _
" Sujet: " & message.Subject & _
" Date: " & message.ReceivedTime & _
" Categorie: " & message.categories & _
"</a><br>"
ElseIf TypeOf message Is TaskItem Then
a = a & "<a href=""outlook:" & message.EntryID & """>" & _
"LIEN OUTLOOK From: " & message.Owner & _
" Sujet: " & message.Subject & _
" Date: " & message.DueDate & _
" Categorie: " & message.categories & _
"</a><br>"
ElseIf TypeOf message Is ReportItem Then
a = a & "<a href=""outlook:" & message.EntryID & """>" & _
"LIEN OUTLOOK From: " & message.Owner & _
" Sujet: " & message.Subject & _
" Date: " & message.CreationTime & _
" Categorie: " & message.categories & _
"</a><br>"
ElseIf TypeOf message Is ContactItem Then
a = a & "<a href=""outlook:" & message.EntryID & """>" & _
"LIEN OUTLOOK From: " & message.FullNameAndCompany & _
" Categorie: " & message.categories & _
"</a><br>"
'" Date: " & message.CreationTime & _
'" Sujet: " & message.Subject & _
Else
a = a & "ERREUR - Un item dans votre sélection n'est pas un message ou tâche - pas de lien<br>"
End If
coplie = a
End Function
Sub categories()
Dim item As Variant
Dim ai As Variant
Dim mb As Object
Dim cmd As Object
Dim mestyp As Variant
Dim a
mestyp = TypeName(Outlook.Application.ActiveWindow)
If mestyp = "Explorer" Then
Set item = Outlook.Application.ActiveExplorer.Selection.item(1)
ElseIf mestyp = "Inspector" Then
Set item = Outlook.Application.ActiveInspector.CurrentItem
End If
On Error Resume Next
item.ShowCategoriesDialog
If mestyp = "Explorer" Then
a = item(1).categories
For Each message In ExplorerMsg.Selection
message.categories = a
'Call cop_mes(message)
Next
'=== si on est dans MESSAGE, seulement le "current"
ElseIf mestyp = "Inspector" Then
'Set message = Outlook.Application.ActiveInspector.CurrentItem
'Call cop_mes(message)
End If
'Set ai = item.Application.ActiveInspector
'Set mb = ai.CommandBars.item("Menu Bar")
'Set cmd = mb.Controls("Edit").Controls("Categories...")
'cmd.Execute
MsgBox ("en développement")
'Dim ol As New Outlook.Application
'Dim cb As Object
'Set cb = ol.ActiveInspector.CommandBars
'cb.item("Edit").Controls("Categories...").Execute
'Dim item As Object
'Dim ExplorerMsg As Explorer
'Dim FolderMsg As MAPIFolder 'Dossier d'où provienne les msg à copier
'Set FolderMsg = ActiveExplorer.CurrentFolder
'Set ExplorerMsg = FolderMsg.GetExplorer
'For Each item In ExplorerMsg.Selection
'item = ExplorerMsg.Selection
'item.ShowCategoriesDialog
'Next
'myDistList.DLName = olSelection.item(1).categories
'myDistList.ShowCategoriesDialog
'item.ShowCategoriesDialog
End Sub
Sub addref()
'Macro purpose: To add a reference to the project using the GUID for the
'reference library
Dim strGUID As String, theRef As Variant, i As Long
'Set objDoc = Application.ActiveInspector.WordEditor
'Update the GUID you need below.
strGUID = "{00020905-0000-0000-C000-000000000046}"
'Set to continue in case of error
On Error Resume Next
'Remove any missing references
'a = Application.ActiveDocument.VBProject.References.Count
'MsgBox (a)
'For i = a To 1 Step -1
' Set theRef = Application.VBProject.References.item(i)
' If theRef.isbroken = True Then
' Application.VBProject.References.Remove theRef
' End If
' MsgBox (theRef)
'Next i
Exit Sub
'Clear any errors so that error trapping for GUID additions can be evaluated
Err.Clear
'Add the reference
Application.VBProject.References.AddFromGuid GUID:=strGUID, Major:=1, Minor:=0
'If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'Reference already in use. No action necessary
Case Is = vbNullString
'Reference added without issue
Case Else
'An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Sub sign()
'=== replace in word object editor
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim a As Variant
'On Error Resume Next
'=== get a Word.Selection from the open Outlook item
Set objDoc = Application.ActiveInspector.WordEditor
Set objSel = objDoc.Windows(1).Selection
Call ini_dep
'=== now do what you want with the Selection
' .Name = "Times New Roman"
' .Size = 10
' .Bold = False
' .Italic = False
' .Underline = wdUnderlineNone
' .UnderlineColor = wdColorAutomatic
' .Strikethrough = False
' .DoubleStrikeThrough = False
' .Outline = False
' .Emboss = False
' .Shadow = False
' .Hidden = False
' .SmallCaps = False
' .AllCaps = False
' .Color = wdColorAutomatic
' .Engrave = False
' .Superscript = False
' .Subscript = False
' .Spacing = 0
' .Scaling = 100
' .Position = 0
' .Kerning = 0
' .Animation = wdAnimationNone
objSel.Font.Name = "Arial"
objSel.Font.Size = 10
If usenam = "fournier.serge" Then
a = "Serge Fournier, Prog./Analyst, département des TI" & vbCrLf
objSel.TypeText a
objSel.Font.Bold = True
a = "STAS Inc." & vbCrLf
objSel.TypeText a
objSel.Font.Bold = False
a = "1846 Outarde, Chicoutimi (Qué.), Canada G7K 1H1" & vbCrLf
a = a & "Tél.: 418-545-6574, ext. 2290" & vbCrLf
a = a & "Fax 1: 418-545-8335, Fax 2: 418-696-1951" & vbCrLf
a = a & "Adresse électronique(Email): mailto: fournier.serge@STAS.biz" & vbCrLf
a = a & "MSNLIVE: msnim:add?contact=fournier.serge.stas.biz@live.ca" & vbCrLf & vbCrLf
objSel.TypeText a
End If
objSel.Font.Name = "Arial"
objSel.Font.Size = 7.5
a = "Avis de confidentialité. La présente communication est confidentielle et transmise sous le sceau du secret professionnel. Si vous n'êtes pas le destinataire visé ou son mandataire chargé de lui transmettre cette communication, vous êtes par la présente avisé qu'il est expressément interdit d'en dévoiler la teneur, de la copier, de la distribuer ou de prendre quelque mesure fondée sur l'information qui y est contenue. Si vous avez reçu cette communication par erreur, veuillez nous en aviser immédiatement par téléphone à frais virés et nous retourner l'original par la poste à l'adresse indiquée plus haut." & vbCrLf & vbCrLf
'=== fra
objSel.LanguageID = wdFrenchCanadian
objSel.TypeText a
'=== eng
'objDoc.Bookmarks("\Para").Select
objSel.LanguageID = wdEnglishUS
a = "Confidential Information. This communication and any attachments are private and may contain legally privileged information. If you are not the authorized recipient, the copying or distribution of this communication or any attachments is prohibited and you must not read, print or act in reliance of this communication. If you have received this communication by mistake, we would appreciate if you could advise us collect call and mail the document at the address indicated above." & vbCrLf
objSel.TypeText a
objSel.LanguageID = wdFrenchCanadian
Set objDoc = Nothing
Set objSel = Nothing
End Sub
Sub lanang()
Call alllan(1)
End Sub
Sub lanfra()
Call alllan(0)
End Sub
Sub alllan(lang)
'=== replace in word object editor
'On Error Resume Next
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim a As Variant
'On Error Resume Next
'=== get a Word.Selection from the open Outlook item
Set objDoc = Application.ActiveInspector.WordEditor
Set objSel = objDoc.Windows(1).Selection
If lang = 0 Then
objSel.LanguageID = wdFrenchCanadian
Else
objSel.LanguageID = wdEnglishUS
End If
End Sub
Sub showErr(sErr)
MsgBox ("Une erreure s'est produits lors de l'exécution du programme :" & Chr(10) & Chr(10) & sErr & Chr(10) & Chr(10) & "Veuillez contacter une ressource informatique.")
End Sub
Sub modSTAS(sForm)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colDrafts As Outlook.Items
Dim colDrafts2 As Outlook.Items
Dim objMail As Outlook.MailItem
Dim objSigMail As Outlook.MailItem
Dim tString As String
Dim aStr, dStr, fStr, gStr, iStr, tStr As String
Dim bInteger, cInteger, hInteger, hInteger2 As Integer
Dim tBool As Boolean
Dim tInt As Integer
Dim adSite As String
Dim strAvis As String
adSite = "http://www.stas.biz/french/_catalogs/images/"
strAvis = "<span style='font-size:7pt;mso-bidi-font-size:11.0pt;mso-fareast-font-family:""Arial"";'><i>Avis de confidentialité</i>. La présente communication est confidentielle et transmise sous le sceau du secret professionnel. Si vous n'êtes pas le destinataire visé ou son mandataire chargé de lui transmettre cette communication, vous êtes par la présente avisé qu'il est expressément interdit d'en dévoiler la teneur, de la copier, de la distribuer ou de prendre quelque mesure fondée sur l'information qui y est contenue. Si vous avez reçu cette communication par erreur, veuillez nous en aviser immédiatement par téléphone à frais virés et nous retourner l'original par la poste à l'adresse indiquée plus haut." & Chr(10) & Chr(10) & _
"<br/><br/><i>Confidential information</i>. This communication and any attachments are private and may contain legally privileged information. If you are not the authorized recipient, the copying or distribution of this communication or any attachments is prohibited and you must not read, print or act in reliance of this communication. If you have received this communication by mistake, we would appreciate if you could advise us collect call and mail the document at the address indicated above."
Unload tmpLogo
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
If Err <> 0 Then showErr (Err)
Set objNS = objOL.GetNamespace("MAPI")
If Err <> 0 Then showErr (Err)
Set objSigMail = objOL.CreateItem(olMailItem)
If Err <> 0 Then showErr (Err)
Set colDrafts = objNS.GetDefaultFolder(olFolderDrafts).Items
If Err <> 0 Then showErr (Err)
Set objMail = colDrafts.Add(sForm)
If Err <> 0 Then showErr (Err)
objMail.BodyFormat = olFormatHTML
objSigMail.Display
If Left(Outlook.Version, 2) = 12 Then
objMail.HTMLBody = objMail.HTMLBody & "<br><br><br>" & objSigMail.HTMLBody
If Err <> 0 Then showErr (Err)
Else
objMail.HTMLBody = objMail.HTMLBody
If Err <> 0 Then showErr (Err)
End If
objSigMail.Close olDiscard
If Err <> 0 Then showErr (Err)
'aStr = "src=" & Chr(34) & "cid:"
aStr = objMail.FormDescription
dStr = LCase(CStr(objMail.HTMLBody))
gStr = CStr(objMail.HTMLBody)
tStr = gStr
tInt = 0
Dim tmpAvis As String
If InStr(gStr, "Avis de confidentialité") = 0 Then
tmpAvis = strAvis
Else
tmpAvis = ""
End If
tStr = Replace(gStr, "AVIS_CONF", tmpAvis)
Do
gStr = tStr
bInteger = 0
tInt = tInt + 1
bInteger = InStr(gStr, aStr & "_" & tInt)
If bInteger <> 0 Then
cInteger = InStr(bInteger + 5, gStr, Chr(34))
If tInt = 1 Then
If InStr(gStr, aStr & "_" & (tInt + 1)) = 0 Then
fStr = "</span></p><img height=117 src=" & Chr(34) & adSite & aStr & "_" & tInt & ".png" & Chr(34) & " align=left hspace=2>"
Else
fStr = "<img width=800 src=" & Chr(34) & adSite & aStr & "_" & tInt & ".png" & Chr(34) & "><br/><br/><br/>"
End If
Else
fStr = "<img height=117 src=" & Chr(34) & adSite & aStr & "_" & tInt & ".png" & Chr(34) & " align=left hspace=2>"
End If
tStr = Replace(gStr, aStr & "_" & tInt, fStr)
tBool = True
Else
tBool = False
End If
Loop While tBool = True
hInteger = InStr(tStr, "<link rel=File-List")
If hInteger <> 0 Then
hInteger2 = InStr(hInteger, gStr, ">")
iStr = Mid(tStr, hInteger, hInteger2 - hInteger + 1)
tStr = Replace(tStr, iStr, " ")
End If
objMail.HTMLBody = tStr
Open "c:\toto.txt" For Append As #1
Write #1, objMail.HTMLBody
Close #1
objMail.Display
Set objOL = Nothing
Set objNS = Nothing
Set colDrafts = Nothing
Set objMail = Nothing
Set objSigMail = Nothing
End Sub
Sub tachesfacturation()
Dim objOL As Outlook.Application
Dim colDrafts As Outlook.Items
Dim objMail As Outlook.TaskItem
Dim objNS As Outlook.NameSpace
Set objOL = CreateObject("Outlook.Application")
Set objNS = objOL.GetNamespace("MAPI")
Set colDrafts = objNS.GetDefaultFolder(olFolderTasks).Items
Set objMail = colDrafts.Add("IPM.Task.TachesFacturation")
'objMail.im
objMail.Display
End Sub
' --------------------------------------------------------------------
' Public Methods
' --------------------------------------------------------------------
Public Function GetFormat(ByVal Format As Long) As Boolean
' Check if the requested format is available
' on the clipboard. (Same behavior as standard
' VB Clipboard object)
If OpenClipboard(0&) Then
If IsClipboardFormatAvailable(Format) Then
GetFormat = True
End If
Call CloseClipboard
End If
End Function
' --------------------------------------------------------------------
Public Function GetPriorityFormat(ParamArray Formats()) As Long
Dim Fmts() As Long
Dim i As Long
Dim nFmt As Long
' Bail, if no formats were requested
If UBound(Formats) < 0 Then Exit Function
' Transfer desired formats into a non-variant array
ReDim Fmts(0 To UBound(Formats)) As Long
For i = 0 To UBound(Formats)
' Double conversion, to be safer.
' Could error trap, but that'd mean the
' user was a hoser, and we wouldn't want
' to insinuate *that*, would we?
Fmts(i) = CLng(Val(Formats(i)))
Next i
' Try opening clipboard...
If OpenClipboard(0&) Then
' Check to see which format is highest in list
nFmt = GetPriorityClipboardFormat(Fmts(0), UBound(Fmts) + 1)
Call CloseClipboard
Else
' Clipboard may already be open by another
' routine in same process, try anyway to see
' if we can get a successful result. Not
' clean, but worth a shot
nFmt = GetPriorityClipboardFormat(Fmts(0), UBound(Fmts) + 1)
End If
' Return results
GetPriorityFormat = nFmt
End Function
' --------------------------------------------------------------------
Public Function GetText() As String
Dim nFmt As Long
Dim hData As Long
Dim lpData As Long
' Check for desired format
'nFmt = Me.GetPriorityFormat(CF_TEXT, CF_OEMTEXT, CF_DSPTEXT)
nFmt = GetPriorityFormat(CF_TEXT, CF_OEMTEXT, CF_DSPTEXT)
' -1=None requested, 0=Empty
If nFmt > 0 Then
' Grab text from clipboard, if available
If OpenClipboard(0&) Then
hData = GetClipboardData(nFmt)
' Slurp characters from global memory
If hData Then
lpData = GlobalLock(hData)
GetText = PointerToStringA(lpData)
Call GlobalUnlock(hData)
End If
Call CloseClipboard
End If
End If
End Function
' --------------------------------------------------------------------
Public Function SetText(ByVal NewVal As String) As Boolean
Dim hData As Long
Dim lpData As Long
Dim Buffer() As Byte
'=== Try to set text onto clipboard
If OpenClipboard(0&) Then
Call EmptyClipboard
'=== Convert data to ANSI byte array
Buffer = StrConv(NewVal & vbNullChar, vbFromUnicode)
'=== Allocate enough memory for buffer
hData = GlobalAlloc(GMEM_FIXED, UBound(Buffer) + 1)
If hData Then
'=== Copy data to alloc'd memory
lpData = GlobalLock(hData)
Call CopyMemory(ByVal lpData, Buffer(0), UBound(Buffer) + 1)
Call GlobalUnlock(hData)
'=== Hand data off to clipboard
SetText = CBool(SetClipboardData(CF_TEXT, hData))
End If
Call CloseClipboard
End If
End Function
Public Function SetHtml(ByVal NewVal As String) As Boolean
Dim hData As Long
Dim lpData As Long
Dim Buffer() As Byte
Dim CF_HTML As Long
Dim n As String
Dim o As Variant
Dim p As Variant
Dim q As Variant
Dim r As String
Dim i As Integer
Dim s As String
'=== replace all special caracters 128+ ascii with a code for html code
i = 1
While i < Len(NewVal)
s = Mid(NewVal, i, 1)
r = Asc(s)
If r > 128 Then
NewVal = Replace(NewVal, s, "&#" & Trim(CStr(r)) & ";")
i = i + 3 + Len(Trim(CStr(r)))
Else
i = i + 1
End If
Wend
'=== build html structure for clipboard
n = "Version:0.9" & vbCrLf
n = n & "StartHTML:00000000" & vbCrLf
n = n & "EndHTML:00000000" & vbCrLf
n = n & "StartFragment:00000000" & vbCrLf
n = n & "EndFragment:00000000" & vbCrLf
n = n & "StartSelection:00000000" & vbCrLf
n = n & "EndSelection:00000000" & vbCrLf
n = n & "<html><body>" & vbCrLf
n = n & "<!--StartFragment-->" & vbCrLf
n = n & NewVal & vbCrLf
n = n & "<!--EndFragment-->" & vbCrLf
n = n & "</BODY></HTML>" & vbCrLf
'Version: vv version number of the clipboard. Starting version is 0.9.
'StartHTML: bytecount from the beginning of the clipboard to the start of the context, or -1 if no context.
'EndHTML: bytecount from the beginning of the clipboard to the end of the context, or -1 if no context.
'StartFragment: bytecount from the beginning of the clipboard to the start of the fragment.
'EndFragment: bytecount from the beginning of the clipboard to the end of the fragment.
'StartSelection: bytecount from the beginning of the clipboard to the start of the selection.
'EndSelection: bytecount from the beginning of the clipboard to the end of the selection.
'=== once the string is done, we can chek where are the chekpoints
'=== then write it in the string itself, padding with "0"
q = "<html>"
p = Trim(CStr(InStr(LCase(n), q) - 1))
o = String(8 - Len(p), "0") & p
n = Replace(n, "StartHTML:00000000", "StartHTML:" & o, 1, 1)
q = ""
p = Trim(CStr(Len(n)))
o = String(8 - Len(p), "0") & p
n = Replace(n, "EndHTML:00000000", "EndHTML:" & o, 1, 1)
q = "<!--startfragment-->"
p = Trim(CStr(InStr(LCase(n), q) + Len(q) - 1))
o = String(8 - Len(p), "0") & p
n = Replace(n, "StartFragment:00000000", "StartFragment:" & o, 1, 1)
q = "<!--endfragment-->"
p = Trim(CStr(InStr(LCase(n), q) - 1))
o = String(8 - Len(p), "0") & p
n = Replace(n, "EndFragment:00000000", "EndFragment:" & o, 1, 1)
'=== Try to set text onto clipboard
If OpenClipboard(0&) Then
Call EmptyClipboard
'=== Convert data to ANSI byte array
Buffer = StrConv(n & vbNullChar, vbFromUnicode)
'=== Allocate enough memory for buffer
hData = GlobalAlloc(GMEM_FIXED, UBound(Buffer) + 1)
If hData Then
'=== Copy data to alloc'd memory
lpData = GlobalLock(hData)
Call CopyMemory(ByVal lpData, Buffer(0), UBound(Buffer) + 1)
Call GlobalUnlock(hData)
'=== Hand data off to clipboard
CF_HTML = RegisterClipboardFormat(RegHtml)
'MsgBox (CF_HTML)
SetHtml = CBool(SetClipboardData(CF_HTML, hData))
End If
Call CloseClipboard
End If
End Function
' --------------------------------------------------------------------
' Private Methods
' --------------------------------------------------------------------
Private Function PointerToStringA(ByVal lpStringA As Long) As String
Dim Buffer() As Byte
Dim nLen As Long
If lpStringA Then
nLen = lstrlenA(ByVal lpStringA)
If nLen Then
ReDim Buffer(0 To (nLen - 1)) As Byte
CopyMemory Buffer(0), ByVal lpStringA, nLen
PointerToStringA = StrConv(Buffer, vbUnicode)
End If
End If
End Function
'Function ClipboardAsDouble() As Double
' ClipboardAsDouble = 0#
'On Error GoTo err_ClipboardAsDouble
' Dim oClipboard As New clsClipboard ' Our own clipboard class
' ClipboardAsDouble = CDbl(oClipboard.GetText)
' Debug.Print "Clipboard=" & CStr(CDbl(oClipboard.GetText))
' Exit Function
'err_ClipboardAsDouble:
' MsgBox "Error no. " & CStr(Err.Number) & ": " & Err.Description, vbCritical Or vbOKOnly, "Error in ClipboardAsDouble"
'End Function
if you manage to understand my vba/macro scripts and make them work
you are no longer a beginner :P
I tought about that and i think there is a "NewInspector" event in outlook
so you could insert the signature when a new message is created with a vba macro
you must chek however if the new item is a "messageitem"
also, your editor, must always be the same (word object)
because modifying a "body" with another editor, will make it "brute text"
good reference: (for vba outlook coding, not signature in particular)
http://msdn.microsoft.com/en-us/library/aa155701(office.10).aspx
i will code this soon and post it here (i need it woo anyway :P)
you are no longer a beginner :P
I tought about that and i think there is a "NewInspector" event in outlook
so you could insert the signature when a new message is created with a vba macro
you must chek however if the new item is a "messageitem"
also, your editor, must always be the same (word object)
because modifying a "body" with another editor, will make it "brute text"
good reference: (for vba outlook coding, not signature in particular)
http://msdn.microsoft.com/en-us/library/aa155701(office.10).aspx
i will code this soon and post it here (i need it woo anyway :P)
alright here is the first part of a specific script for auto sign
(tested in outlook 2007, word as editor)
you must put this code in ALT F11, this outlooksession
you can clean it a lot, i have lots of gadgets
the signature part is at the end of the script
i call network object for name of the user
but i go get the ad object for more details, but i did not finish it yet so...
(tested in outlook 2007, word as editor)
you must put this code in ALT F11, this outlooksession
you can clean it a lot, i have lots of gadgets
the signature part is at the end of the script
i call network object for name of the user
but i go get the ad object for more details, but i did not finish it yet so...
'=== trigger an event if an item is sent
Dim WithEvents colSentItems As Items
'Public WithEvents newItem As Outlook.MailItem
Dim myOlApp As New Outlook.Application
Public WithEvents myOlInspectors As Outlook.Inspectors
Private Sub colSentItems_ItemAdd(ByVal item As Object)
'=== modifier la catégorie avant d'envoyer un message
If item.Class = olMail Then
If flag_env_tfr = 1 Then
'Item.ShowCategoriesDialog
On Error Resume Next
'Call cop_mes(item)
On Error GoTo 0
flag_env_tfr = 0
End If
End If
End Sub
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
'=== corrige les liens dans les messages avant de les envoyer
Dim objshe As Object
Dim objEnv As Object
Dim objFSO As Object
On Error Resume Next
Set objshe = CreateObject("WScript.Shell")
Set objEnv = objshe.Environment("PROCESS")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim intRes As Integer
Dim strMsg As String
Dim strThismsg As String
Dim intOldmsgstart As Integer
'=== global variables or setup
objEnv("SEE_MASK_NOZONECHECKS") = 1
script01 = "c:\windows\system32\wscript.exe"
script02 = "C:\_stas\scripts\notification_balloon.vbs"
'=== scan body of email message before sending to correct hyperlink from word editor
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim a As Variant
On Error Resume Next
'=== word is the editor, we can use it
If ActiveInspector.IsWordMail = True Then
Set objDoc = Application.ActiveInspector.WordEditor
'=== word is the editor
'Set objSel = objDoc.Windows(1).Selection
Set colHyperlinks = objDoc.Hyperlinks
For Each objHyperlink In colHyperlinks
a = objHyperlink.Address
b = objHyperlink.TextToDisplay
If InStr(a, "file://") = 0 And InStr(a, "file:///") = 0 And InStr(a, ":\") <> 0 Then
objHyperlink.TextToDisplay = "file://" & objHyperlink.Address
End If
Next objHyperlink
Else
'=== outlook editor, text is brut text
a = item.Body
b = ""
If InStr(LCase(a), ":\") > 0 Then
For i = 1 To Len(a)
If i + 1 < Len(a) Then
If InStr("abcdefghijklmnopqrstuvwxyz", LCase(Mid(a, i, 1))) And Mid(a, i + 1, 2) = ":\" Then
c = 0
d = 0
If i - 8 > 0 Then
c = InStr(LCase(Mid(a, i - 8, 8)), "file:///")
End If
If i - 7 > 0 Then
d = InStr(LCase(Mid(a, i - 7, 7)), "file://")
End If
If c = 0 And d = 0 Then
b = b + "file://"
Else
'b = b + "file://"
End If
End If
End If
b = b + Mid(a, i, 1)
Next
'sMsg = "result before sending" + vbCrLf + b
a = script01 & " " & script02 & " DEBUT ""Message modifé`n`nmise en page texte brut`n"" 15 1+16"
On Error Resume Next
'objshe.Run a, , False
On Error GoTo 0
objEnv.Remove ("SEE_MASK_NOZONECHECKS")
'intRes = MsgBox(sMsg, vbYesNo + vbDefaultButton2 + vbExclamation, "result before sending")
'If intRes = vbNo Then
'=== cancel send
' Cancel = True
'item.Body = b
End If
End If
End Sub
Public Sub Application_Startup()
'==========================================================
'=== add stas generics buttons, then departement buttons
Call ajout_boutons(0)
'=== open a mail and add buttons
Dim objMail As Object
Set objMail = CreateItem(olMailItem)
objMail.Display
Call ajout_boutons(1)
objMail.Close olDiscard
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
Set colSentItems = NS.GetDefaultFolder(olFolderSentMail).Items
Set NS = Nothing
'set RibbonControls.Button button = new RibbonControls.Button(System.Windows.Input.ApplicationCommands.Paste)
'ribbon.QuickAccessToolBarItems.Add (Button)
'RibbonControl.Toolbar.SaveLayoutToXml
'RibbonControl.Toolbar.RestoreLayoutFromXml
' C1Ribbon1.Qat.Items.Add(New RibbonButton(My.Resources.Resources.save))
' C1Ribbon1.Qat.Items.Add(New RibbonButton(My.Resources.Resources.undo))
' C1Ribbon1.Qat.Items.Add(New RibbonButton(My.Resources.Resources.repeat))
Set myOlInspectors = myOlApp.Inspectors
End Sub
'=== futur manipulate word text editor in outlook 2007
Sub Euro()
Dim objDoc As Word.Document
Dim objSel As Word.Selection
On Error Resume Next
' get a Word.Selection from the open Outlook item
Set objDoc = Application.ActiveInspector.WordEditor
Set objSel = objDoc.Windows(1).Selection
' now do what you want with the Selection
objSel.TypeText "¬"
Set objDoc = Nothing
Set objSel = Nothing
End Sub
Private Sub newItem_AttachmentAdd(ByVal newAttachment As Attachment)
MsgBox (newItem.Size)
If newAttachment.Type = olByValue Then
newItem.Save
If newItem.Size > 5000 Then
MsgBox "Warning: Item size is now " & newItem.Size & " bytes."
End If
End If
End Sub
Private Sub myOlInspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim CurrentUser As Object
Dim objNet As Object
' get a Word.Selection from the open Outlook item
Set objNet = CreateObject("WScript.Network")
usenam = LCase(objNet.UserName)
Set objDoc = Inspector.WordEditor
Set objSel = objDoc.Windows(1).Selection
objSel.TypeText "test1"
Set objUser = CreateObject("ADSystemInfo")
Set CurrentUser = GetObject("LDAP://" & objUser.UserName)
If Err <> 0 Then
'=== pas de domaine disponible
domsta = 0
Else
On Error Resume Next
usegrp = LCase(Join(CurrentUser.MemberOf)) '=== list of all groups user is in
domsta = 1
End If
objSel.TypeText usenam
'Inspector.CommandBars.item("Standard").Visible = True
'Inspector.CommandBars.item("Formatting").Visible = True
End Sub
oops i will have to change a few things, the script run when you open any message lol
ill post later, working on it
ill post later, working on it
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.