I would like to compare the value form my ComboBox, coded as " & strQ & ", with the values from the first column on page "6 - Liste des Partenaires". The Range "Chapeau_Partenaire" is in A1.
I'm newer in VBA, I don't know how to code the function If then Do. It appears in red in my code. Thank you very much for your help.
Public Sub INFO_PROTO(ByRef strQ As String)
Num_Ligne = Range("Chapeau_Partenaire").Row + 1
While Worksheets("6 - Liste des Partenaires").Cells(Num_Ligne, Range("Chapeau_Partenaire").Column) <> ""
if " & strQ & " = Worksheets("6 - Liste des Partenaires").Cells(Num_Ligne, Range("Chapeau_Partenaire").Column)
Then Do
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_CMA_Origine") = "1"
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_Perf_Contrat_et_Orient") = "1"
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_CMA_Perf_An") = "1"
Else
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_CMA_Origine") = "1"
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_Perf_Contrat_et_Orient") = "0"
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_CMA_Perf_An") = "0"
End If
Num_Ligne = Num_Ligne + 1
Wend
End Sub
You don't need quotes around and you don't need Do.
Public Sub INFO_PROTO(ByRef strQ As String)
Dim Num_Ligne As Long
Num_Ligne = Range("Chapeau_Partenaire").Row + 1
While Worksheets("6 - Liste des Partenaires").Cells(Num_Ligne, Range("Chapeau_Partenaire").Column) <> ""
If strQ = Worksheets("6 - Liste des Partenaires").Cells(Num_Ligne, Range("Chapeau_Partenaire").Column) Then
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_CMA_Origine") = "1"
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_Perf_Contrat_et_Orient") = "1"
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_CMA_Perf_An") = "1"
Else
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_CMA_Origine") = "1"
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_Perf_Contrat_et_Orient") = "0"
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_CMA_Perf_An") = "0"
End If
Num_Ligne = Num_Ligne + 1
Wend
End Sub
Related
(Since I'm from Brazil, there is some text in Portuguese, so if you need some help, just let me know).
I've got 2 macros in my Outlook "This Outlook Session" in 1 master macro that calls the others 2 that I mentioned before.
The master macro do:
Macro name: "Salvar_CNAB_Registro"
Discovers the subject of the e-mail and give the path I want depending what it's writing.
After discover the path, save all the attachments from e-mail on the path discovered.
Sub Salvar_CNAB_Registro(Email As MailItem)
'Dim strSubject As String
Dim objMsg As Outlook.MailItem
Dim objSubject As String
objSubject = Email.Subject
'Defino qual caminho salvará os registros dos arquivos CNAB dependendo do produto da Funcesp ou da forma de liquidação
If InStr(1, objSubject, "Registro de Boletos de Saúde - Vencimento") > 0 Then
DiretorioAnexos = "S:\AFTData\OUTBOX\GE201658\"
'DiretorioAnexos = "K:\Divisao_Administrativa_Financeira\Tesouraria\Contas_Receber\COBRANÇAS\SAÚDE\2019\03 MARÇO 2019\25.03.2019\TESTE\"
ElseIf InStr(1, objSubject, "Registro de Boletos de Autopatrocínio - Vencimento") > 0 Then
DiretorioAnexos = "S:\AFTData\OUTBOX\GE201658\"
ElseIf InStr(1, objSubject, "Registro de Boletos de Seguros - Vencimento") > 0 Then
DiretorioAnexos = "S:\AFTData\OUTBOX\GE201717\"
ElseIf InStr(1, objSubject, "Registro de Débito Automático de Saúde - Vencimento") > 0 Then
DiretorioAnexos = "S:\AFTData\OUTBOX\GE201775\"
ElseIf InStr(1, objSubject, "Registro de Débito Automático de Autopatrocínio - Vencimento") > 0 Then
DiretorioAnexos = "S:\AFTData\OUTBOX\GE201775\"
ElseIf InStr(1, objSubject, "Registro de Débito Automático de Seguros - Vencimento") > 0 Then
DiretorioAnexos = "S:\AFTData\OUTBOX\GE201775\"
ElseIf InStr(1, objSubject, "Registro de Boletos de Empréstimo") > 0 Then
DiretorioAnexos = "S:\AFTData\OUTBOX\GE201717\"
End If
Debug.Print "Diretório Macro Salvar_CNAB_Registro:"
Debug.Print DiretorioAnexos
Dim MailID As String
Dim Mail As Outlook.MailItem
MailID = Email.EntryID
Set Mail = Application.Session.GetItemFromID(MailID)
'Verifico se o anexo no e-mail é arquivo unixo TXT e salvo todos
For Each Anexo In Mail.Attachments
If Right(Anexo.FileName, 3) = "txt" Then
Anexo.SaveAsFile DiretorioAnexos & "\" & Anexo.FileName
End If
Next
'Verifico se o anexo no e-mail é arquivo unixo zip e salvo todos
For Each Anexo In Mail.Attachments
If Right(Anexo.FileName, 3) = "zip" Then
Anexo.SaveAsFile DiretorioAnexos & Anexo.FileName
Call Unzipar_Arquivos
End If
Next
DoEvents
Call Reply_Email
Set Mail = Nothing
End Sub
The first macro do:
Macro name: Unzipar_Arquivos (calls the macro UnzipAFile)
It has two macros, it unzip any zip file attached in any e-mail called by the rule on Outlook.
Sub UnzipAFile(zippedFileFullName As Variant, unzipToPath As Variant)
Dim ShellApp As Object
'Copy the files & folders from the zip into a folder
Set ShellApp = CreateObject("Shell.Application")
ShellApp.NameSpace(unzipToPath).CopyHere ShellApp.NameSpace(zippedFileFullName).Items
End Sub
Sub Unzipar_Arquivos()
Dim diretorio As Variant
Dim diretorio_ext As Variant
Dim nome_arquivo As String
'------------------------------------ Extraio os arquivos da pasta do Santander Outbox 1658 --------------------------------'
'Caminho que o arquivo será unzipado
diretorio_ext = "S:\AFTData\OUTBOX\GE201658\"
'Descobre o nome do arquivo zip + caminho que ele se encontra
nome_arquivo = Dir(diretorio_ext & "*.zip")
'Caminho que encontra-se o arquivo zipado
diretorio = "S:\AFTData\OUTBOX\GE201658\" & nome_arquivo
'Executo a macro enquanto houver arquivos zipados na pasta
Do While Len(nome_arquivo) > 0
'A primeira parte refere-se ao nome do arquivo que será unzipado, e a segunda parte refere-se ao caminho que ele será unzipado
Call UnzipAFile(diretorio, diretorio_ext)
'Apago o primeiro arquivo zip que foi extraído
'Primeiro remove o atributo de arquivo "somente leitura" caso esteja definido
On Error Resume Next
SetAttr FileToDelete, vbNormal
'Depois apago o arquivo
Kill diretorio
'Procura o próximo arquivo
nome_arquivo = Dir
'Exibe mensagem de sucesso
MsgBox "Arquivo " & nome_arquivo & "descompactado e arquivos registrados! " & "no diretório: " & diretorio_ext
Loop
'------------------------------------ Extraio os arquivos da pasta do Santander Outbox 1717 --------------------------------'
'Caminho que o arquivo será unzipado
diretorio_ext = "S:\AFTData\OUTBOX\GE201717\"
'Descobre o nome do arquivo zip + caminho que ele se encontra
nome_arquivo = Dir(diretorio_ext & "*.zip")
'Caminho que encontra-se o arquivo zipado
diretorio = "S:\AFTData\OUTBOX\GE201717\" & nome_arquivo
'Executo a macro enquanto houver arquivos zipados na pasta
Do While Len(nome_arquivo) > 0
'A primeira parte refere-se ao nome do arquivo que será unzipado, e a segunda parte refere-se ao caminho que ele será unzipado
Call UnzipAFile(diretorio, diretorio_ext)
'Apago o primeiro arquivo zip que foi extraído
'Primeiro remove o atributo de arquivo "somente leitura" caso esteja definido
On Error Resume Next
SetAttr FileToDelete, vbNormal
'Depois apago o arquivo
Kill diretorio
'Procura o próximo arquivo
nome_arquivo = Dir
'Exibe mensagem de sucesso
MsgBox "Arquivo " & nome_arquivo & "descompactado e arquivos registrados! " & "no diretório: " & diretorio_ext
Loop
'------------------------------------ Extraio os arquivos da pasta do Santander Outbox 1775 --------------------------------'
'Caminho que o arquivo será unzipado
diretorio_ext = "S:\AFTData\OUTBOX\GE201775\"
'Descobre o nome do arquivo zip + caminho que ele se encontra
nome_arquivo = Dir(diretorio_ext & "*.zip")
'Caminho que encontra-se o arquivo zipado
diretorio = "S:\AFTData\OUTBOX\GE201775\" & nome_arquivo
'Executo a macro enquanto houver arquivos zipados na pasta
Do While Len(nome_arquivo) > 0
'A primeira parte refere-se ao nome do arquivo que será unzipado, e a segunda parte refere-se ao caminho que ele será unzipado
Call UnzipAFile(diretorio, diretorio_ext)
'Apago o primeiro arquivo zip que foi extraído
'Primeiro remove o atributo de arquivo "somente leitura" caso esteja definido
On Error Resume Next
SetAttr FileToDelete, vbNormal
'Depois apago o arquivo
Kill diretorio
'Procura o próximo arquivo
nome_arquivo = Dir
'Exibe mensagem de sucesso
MsgBox "Arquivo " & nome_arquivo & "descompactado e arquivos registrados! " & "no diretório: " & diretorio_ext
Loop
End Sub
The second macro do:
Macro name: Reply_Email
Discover the name of each file that was saved before and then add the name on the body of the HTML e-mail that it's going to reply to all.
Sub Reply_Email()
Dim strFolder As String
Const strPattern As String = "*.txt"
Dim strFile As String
Dim nome_cnab As String
Dim quantidade As Integer
Dim add_msg As String
Dim validador As Integer
Dim i As Integer
Debug.Print "Diretório Macro Responder_Email:"
Debug.Print strFolder
'Define o nome do caminho de acordo com o assunto (produto da funcesp que o cnab está sendo registrado) do e-mail enviado pelo funcionário solicitando o registro
strFolder = DiretorioAnexos
'Define a quantidade inicial de arquivos dentro da pasta que foi registrada
quantidade = 0
'Define o validador inicial igual a 0, isso significa que ainda não começou a montar o e-mail de resposta para a pessoa
validador = 0
'Nome do passo quando ele montar o e-mail, e adicionará os nomes dos arquivos cnab através do loop
Add_Nome_Cnab:
strFile = Dir(strFolder & strPattern, vbNormal)
Do While Len(strFile) > 0
'Caso queira ver o nome do arquivo CNAB na janela de verificação imediata (CTRL + G)
'Debug.Print strFile
strFile = Dir
nome_cnab = strFile
'Adiciono 1 na quantidade toda vez que passar por aqui, assim teremos a quantidade de arquivos salvos de cada e-mail
quantidade = quantidade + 1
'Se o validador for 1, ele grava o nome do arquivo na variavel
If validador = 1 Then
add_msg = nome_cnab
'Vai para o passo de adicionar de fato o nome do arquivo no corpo do e-mail através da variavel criada acima
GoTo Check_Validador
End If
Loop
Dim olItem As Outlook.MailItem
Dim olReply As MailItem ' Reply
For Each olItem In Application.ActiveExplorer.Selection
Set olReply = olItem.ReplyAll
'Define o validador como 1, para começar a montar o e-mail
validador = 1
'Se tiver 1 arquivo ou mais, ele começa a montar o e-mail
If quantidade > 0 Then
For i = 1 To quantidade
'Vai para o passo de gravar o nome do arquivo na variavel
GoTo Add_Nome_Cnab
Check_Validador:
'Essa etapa que ele adiciona de fato o nome no corpo do e-mail através da variavel criada acima
olReply.HTMLBody = "<br>" & add_msg & vbCrLf & olReply.HTMLBody
DoEvents
Next i
Else
olReply.HTMLBody = "<br>" & "Nenhum arquivo CNAB registrado" & "<br>" & vbCrLf & olReply.HTMLBody
End If
'Escreve as duas primeiras linhas no corpo do e-mail: "Arquivos registrados no dia e hora: " + Data e Hora + "Segue arquivos registrados: "
olReply.HTMLBody = "<br>" & "Arquivos registrados no dia e hora: " & Now & "<br>" & "Segue arquivos registrados: " & "<br>" & vbCrLf & olReply.HTMLBody
DoEvents
'Mostra o e-mail na tela
olReply.Display
DoEvents
'Envia o e-mail
olReply.Send
DoEvents
Next olItem
End Sub
All the macros works as a charm individually, but my problem is when the master macro "Salvar_CNAB_Registro" calls the last macro (Reply_Email) and the e-mail doesn't send by itself automatically.
So, if I run the script alone, it works!!! But, it doesn't work called by another macro.
EDIT 1:
I did some tests, but still can't work unless I debug.
What I did:
Added the macro to test all the macros together, each one calling each other.
Sub Test()
Dim x, mailItem As Outlook.mailItem
For Each x In Application.ActiveExplorer.Selection
If TypeName(x) = "MailItem" Then
Set mailItem = x
Call Salvar_CNAB_Registro(mailItem)
End If
Next
End Sub
So, still works sending the e-mail by debugging but it doesn't work by calling from the rule. I mean, all the macro works, but only don't display and send the e-mail.
I tried the solution from #0m3r, removing the line Application.ActiveExplorer.Selection from the macro Reply_Email, using Sub Reply_Email(ByVal Email As Object) and then calling it like Reply_Email(Email), but this method don't work.
I tried even using Sub Reply_Email(Email As Outlook.mailItem) and then calling it like Reply_Email(Email), this method worked by debugging again, but not automatically.
I also tried this method (How to Auto Reply with Outlook rule), by replying the e-mail from the rule directly but the original message in the body was not there, also I can't sign this code in my work.
It worked! I followed #0m3r tips, and also I did some research on web to try to fix this issue.
What I did:
Now, my macro is Sub Reply_Email(ByVal Email As Object) I named only Dim olReply As mailItem and Set olReply = Email.ReplyAll.
And the main difference that I saw was this part:
With olReply
'Envia o e-mail
.Send
End With
So after added this, the e-mail was send. The macro is called by Call Reply_Email(Email).
And finally, I added a rule that will not reply the e-mail if there is the word "ENC:" or "RES:" in the subject, it means that if there is some reply e-mail in the inbox, it will do nothing.
I have a problem. I succeeded to make a document with a form filled by the user and a control board with few buttons to send, print or save the document when automaticcaly modified by the userform.
My problem is that for an unknown reason, when hitting one of those (print, save or send) button, the text form fields are reseting to default values.
Do you have any idea why ?
(I'm adding all the code below cause I've got no idea where is the problem coming from)
I tried deleting all the code step by step to find what was making that but it didn't give any explanation. I try remaking the document but I get the same trouble.
MENU_FORM :
Private Sub UserForm_Activate()
Dim AppXPoint, AppYPoint As Long
AppXPoint = Application.Left + (Application.Width - Me.Width)
AppYPoint = Application.Top
With Me
.StartUpPosition = 0
.Left = AppXPoint - 200
.Top = AppYPoint + 250
End With
End Sub
Private Sub OUVRIR_FORMULAIRE_BOUTON_Click()
MENU_FORM.Hide
Load FORMULAIRE_FORM
FORMULAIRE_FORM.Show
End Sub
Private Sub IMPRIMER_BOUTON_Click()
ActiveDocument.PrintOut Copies:=1
End Sub
Private Sub QUITTER_BOUTON_Click()
ActiveDocument.Saved = True
Application.Quit
End Sub
Sub ENREGISTRER_BOUTON_Click()
Dim strNewFolderName As String
strNewFolderName = "DÉLÉGATION DE POUVOIRS POUR DÉPÔT DE PLAINTE - " &
UCase(FORMULAIRE_FORM.DELEGATAIRE_PRENOM_TEXT) & " " & UCase(FORMULAIRE_FORM.DELEGATAIRE_NOM_TEXT)
If Len(Dir("S:\EDS-02450\JURIDIQUE\5 - CONTENTIEUX\3 - PÉNAL\" & strNewFolderName, vbDirectory)) = 0 Then
MkDir ("S:\EDS-02450\JURIDIQUE\5 - CONTENTIEUX\3 - PÉNAL\" & strNewFolderName)
End If
Dim PathName As String
PathName = "DÉLÉGATION DE POUVOIRS POUR DÉPÔT DE PLAINTE - " & UCase(FORMULAIRE_FORM.DELEGATAIRE_PRENOM_TEXT) & " " & UCase(FORMULAIRE_FORM.DELEGATAIRE_NOM_TEXT)
ActiveDocument.SaveAs2 FileName:="S:\EDS-02450\JURIDIQUE\5 - CONTENTIEUX\3 - PÉNAL\" & strNewFolderName & "\" & PathName & ".pdf", _
FileFormat:=wdFormatPDF
MsgBox "Le fichier a bien été enregistré sous S:\EDS-02450\JURIDIQUE\5 - CONTENTIEUX\3 - PÉNAL\" & strNewFolderName
End Sub
Sub ENVOYER_BOUTON_Click()
Dim strNewFolderName As String
strNewFolderName = "DÉLÉGATION DE POUVOIRS POUR DÉPÔT DE PLAINTE - " & UCase(FORMULAIRE_FORM.DELEGATAIRE_PRENOM_TEXT) & " " & UCase(FORMULAIRE_FORM.DELEGATAIRE_NOM_TEXT)
If Len(Dir("S:\EDS-02450\JURIDIQUE\5 - CONTENTIEUX\3 - PÉNAL\" & strNewFolderName, vbDirectory)) = 0 Then
MkDir ("S:\EDS-02450\JURIDIQUE\5 - CONTENTIEUX\3 - PÉNAL\" & strNewFolderName)
End If
Dim PathName As String
PathName = "DÉLÉGATION DE POUVOIRS POUR DÉPÔT DE PLAINTE - " & UCase(FORMULAIRE_FORM.DELEGATAIRE_PRENOM_TEXT) & " " & UCase(FORMULAIRE_FORM.DELEGATAIRE_NOM_TEXT)
ActiveDocument.SaveAs2 FileName:="S:\EDS-02450\JURIDIQUE\5 - CONTENTIEUX\3 - PÉNAL\" & strNewFolderName & "\" & PathName & ".pdf", _
FileFormat:=wdFormatPDF
Dim fichier
fichier = "S:\EDS-02450\JURIDIQUE\5 - CONTENTIEUX\3 - PÉNAL\" & strNewFolderName & "\" & PathName & ".pdf"
Dim adresse
adresse = FORMULAIRE_FORM.DELEGATAIRE_PRENOM_TEXT & "." & FORMULAIRE_FORM.DELEGATAIRE_NOM_TEXT & "#azerty.fr"
Outlook: Set myApp = CreateObject("Outlook.Application")
Set myItem = myApp.CreateItem(olMailItem)
myItem.Subject = strNewFolderName
myItem.Body = "Bonjour " & UCase(Left(FORMULAIRE_FORM.DELEGATAIRE_PRENOM_TEXT, 1)) & LCase(Mid(FORMULAIRE_FORM.DELEGATAIRE_PRENOM_TEXT, 2, 9 ^ 9)) & vbCrLf & vbCrLf & "Je vous prie de trouver en pièce jointe une délégation de pouvoirs à l'effet de déposer plainte pour les faits rapportés." & vbCrLf & vbCrLf & "Bonne journée," & vbCrLf & vbCrLf & "Service Juridique"
myItem.Attachments.Add fichier
myItem.to = adresse
If adresse = "" Then
Exit Sub
End If
myItem.Display
myItem.Send
MsgBox "Le courriel a bien été envoyé à " & UCase(Left(FORMULAIRE_FORM.DELEGATAIRE_PRENOM_TEXT, 1)) & LCase(Mid(FORMULAIRE_FORM.DELEGATAIRE_PRENOM_TEXT, 2, 9 ^ 9)) & " " & UCase(FORMULAIRE_FORM.DELEGATAIRE_NOM_TEXT) & " et le fichier a bien été enregistré sous S:\EDS-02450\JURIDIQUE\5 - CONTENTIEUX\3 - PÉNAL\" & strNewFolderName
End Sub
FORMULAIRE_FORM :
Private Sub UserForm_Activate()
Dim AppXPoint, AppYPoint As Long
AppXPoint = Application.Left + (Application.Width - Me.Width)
AppYPoint = Application.Top
With Me
.StartUpPosition = 0
.Left = AppXPoint - 200
.Top = AppYPoint + 250
End With
End Sub
Private Sub UserForm_Initialize()
DELEGATAIRE_CIVILITE_BOX.AddItem "Monsieur"
DELEGATAIRE_CIVILITE_BOX.AddItem "Madame"
DELEGATAIRE_FONCTION_BOX.AddItem "Directeur de secteur"
DELEGATAIRE_FONCTION_BOX.AddItem "Directeur d'agence"
DELEGATAIRE_FONCTION_BOX.AddItem "Adjoint au directeur d'agence"
AUTEUR_BOX.AddItem "X"
AUTEUR_BOX.AddItem "1 personne déterminée"
AUTEUR_BOX.AddItem "2 personnes déterminées"
FAITS_BOX.AddItem "Escroquerie"
FAITS_BOX.AddItem "Usurpation d'identité"
FAITS_BOX.AddItem "Faux et usage de faux"
FAITS_BOX.AddItem "Vol"
FAITS_BOX.AddItem "Dégradation des biens de l'agence"
FAITS_BOX.AddItem "Abus de faiblesse"
FAITS_BOX.AddItem "Abus de confiance"
FAITS_BOX.AddItem "Diffamation"
FAITS_BOX.AddItem "Atteinte à l'honneur"
FAITS_BOX.AddItem "Menaces"
FAITS_BOX.AddItem "Injures"
End Sub
Private Sub AUTEUR_BOX_Change()
If AUTEUR_BOX = "1 personne déterminée" Then
FORMULAIRE_FORM.Hide
Load AUTEUR_FORM
AUTEUR_FORM.Show
ElseIf AUTEUR_BOX = "2 personnes déterminées" Then
FORMULAIRE_FORM.Hide
Load AUTEURS_FORM
AUTEURS_FORM.Show
Else:
End If
End Sub
Private Sub OK_BOUTON_Click()
Dim A As String 'Civilité délégataire
Dim B As String 'Prénom délégataire
Dim C As String 'NOM délégataire
Dim D As String 'Fonction délégataire
Dim E As String 'Lieu des fonctions du délégataire
Dim F As String 'Auteur
Dim G As String 'Faits
Dim H As String 'Date
A = DELEGATAIRE_CIVILITE_BOX
If DELEGATAIRE_CIVILITE_BOX <> "Monsieur" And DELEGATAIRE_CIVILITE_BOX <> "Madame" Then
MsgBox "Veuillez renseigner la civilité du délégataire", vbExclamation, "Erreur"
Exit Sub
End If
If DELEGATAIRE_CIVILITE_BOX = "" Then
MsgBox "Veuillez renseigner la civilité du délégataire", vbExclamation, "Erreur"
Exit Sub
End If
B = UCase(Left(DELEGATAIRE_PRENOM_TEXT, 1)) & LCase(Mid(DELEGATAIRE_PRENOM_TEXT, 2, 9 ^ 9))
If DELEGATAIRE_PRENOM_TEXT = "Prénom" Or DELEGATAIRE_PRENOM_TEXT = "" Then
MsgBox "Veuillez renseigner le prénom du délégataire", vbExclamation, "Erreur"
Exit Sub
End If
C = UCase(DELEGATAIRE_NOM_TEXT)
If DELEGATAIRE_NOM_TEXT = "NOM" Or DELEGATAIRE_NOM_TEXT = "" Then
MsgBox "Veuillez renseigner le nom du délégataire", vbExclamation, "Erreur"
Exit Sub
End If
If DELEGATAIRE_FONCTION_BOX = "directeur d'agence" Then
D = "Directeur de l'agence"
ElseIf DELEGATAIRE_FONCTION_BOX = "Adjoint au directeur d'agence" Then
D = "adjoint au directeur de l'agence"
ElseIf DELEGATAIRE_FONCTION_BOX = "Directeur de secteur" Then
D = "directeur du secteur"
Else
D = DELEGATAIRE_FONCTION_BOX
End If
If DELEGATAIRE_FONCTION_BOX = "Fonction" Or DELEGATAIRE_FONCTION_BOX = "" Then
MsgBox "Veuillez renseigner la fonction du délégataire", vbExclamation, "Erreur"
Exit Sub
End If
E = DELEGATAIRE_LIEU_TEXT
If DELEGATAIRE_LIEU_TEXT = "Nom de l'agence ou du secteur" Or DELEGATAIRE_LIEU_TEXT = "" Then
MsgBox "Veuillez renseigner la zone d'exercice des fonctions du délégataire", vbExclamation, "Erreur"
Exit Sub
End If
If AUTEUR_BOX = "1 personne déterminée" Then
F = UCase(Left(AUTEUR_FORM.PRENOM_TEXT, 1)) & LCase(Mid(AUTEUR_FORM.PRENOM_TEXT, 2, 9 ^ 9)) + "" + UCase(AUTEUR_FORM.NOM_TEXT)
ElseIf AUTEUR_BOX = "2 personnes déterminées" Then
F = UCase(Left(AUTEURS_FORM.AUTEUR1_PRENOM_TEXT, 1)) & LCase(Mid(AUTEURS_FORM.AUTEUR1_PRENOM_TEXT, 2, 9 ^ 9)) + " " + UCase(AUTEURS_FORM.AUTEUR1_NOM_TEXT) + " " + "et" + " " + UCase(Left(AUTEURS_FORM.AUTEUR2_PRENOM_TEXT, 1)) & LCase(Mid(AUTEURS_FORM.AUTEUR2_PRENOM_TEXT, 2, 9 ^ 9)) + " " + UCase(AUTEURS_FORM.AUTEUR2_NOM_TEXT)
Else: F = UCase(AUTEUR_BOX)
End If
If AUTEUR_BOX = "Auteur" Or AUTEUR_BOX = "" Then
MsgBox "Veuillez renseigner le(s) auteur(s) des faits", vbExclamation, "Erreur"
Exit Sub
End If
If FAITS_BOX = "Escroquerie" Then
G = "pour escroquerie"
ElseIf FAITS_BOX = "Usurpation d'identité" Then
G = "pour usurpation d'identité"
ElseIf FAITS_BOX = "Faux et usage de faux" Then
G = "pour faux et usage de faux"
ElseIf FAITS_BOX = "Vol" Then
G = "pour vol"
ElseIf FAITS_BOX = "Dégradation des biens de l'agence" Then
G = "pour dégradation des biens de l'agence"
ElseIf FAITS_BOX = "Abus de faiblesse" Then
G = "pour abus de faiblesse"
ElseIf FAITS_BOX = "Abus de confiance" Then
G = "pour abus de confiance"
ElseIf FAITS_BOX = "Diffamation" Then
G = "pour diffamation"
ElseIf FAITS_BOX = "Atteinte à l'honneur" Then
G = "pour atteinte à l'honneur"
ElseIf FAITS_BOX = "Menaces" Then
G = "suite à des menaces"
ElseIf FAITS_BOX = "Injures" Then
G = "suite à des injures"
Else
G = FAITS_BOX
End If
If FAITS_BOX = "Faits" Or FAITS_BOX = "" Then
MsgBox "Veuillez renseigner les faits", vbExclamation, "Erreur"
Exit Sub
End If
H = Format(Date, "dd mmmm yyyy")
ActiveDocument.FormFields("A").Result = A
ActiveDocument.FormFields("B").Result = B
ActiveDocument.FormFields("C").Result = C
ActiveDocument.FormFields("D").Result = D
ActiveDocument.FormFields("E").Result = E
ActiveDocument.FormFields("F").Result = F
ActiveDocument.FormFields("G").Result = G
ActiveDocument.FormFields("H").Result = H
FORMULAIRE_FORM.Hide
MENU_FORM.Show
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
Unload FORMULAIRE_FORM
FORMULAIRE_FORM.Hide
Load MENU_FORM
MENU_FORM.Show
End If
End Sub
Private Sub ANNULER_BOUTON_Click()
A = "civilité"
B = "prénom du délégataire"
C = "nom du délégataire"
D = "fonction du délégataire"
E = "lieu d'exercice des fonctions du délégataire"
F = "auteur(s)"
G = "pour les faits"
H = "date"
ActiveDocument.FormFields("A").Result = A
ActiveDocument.FormFields("B").Result = B
ActiveDocument.FormFields("C").Result = C
ActiveDocument.FormFields("D").Result = D
ActiveDocument.FormFields("E").Result = E
ActiveDocument.FormFields("F").Result = F
ActiveDocument.FormFields("G").Result = G
ActiveDocument.FormFields("H").Result = H
Unload FORMULAIRE_FORM
Unload AUTEUR_FORM
Unload AUTEURS_FORM
FORMULAIRE_FORM.Hide
Load MENU_FORM
MENU_FORM.Show
End Sub
Your problem is that you're using formfields in a document that doesn't have 'filling in forms' protection applied. You can apply that protection to the document before your code does anything with it (e.g. apply it manually to whatever template or document you're using), or you could use code like:
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReSet:=True
and run that upon opening or before printing, saving or sending.
I'm trying to do write a VBA script that takes the body of an incoming email and sends it on to another person.
If I don't open the email the .body is empty and the email that is then sent is empty as well.
However when I open the email and then manually execute the script, it works and then .body isn't empty.
Here is the code I'm using:
Option Explicit
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Folders("Test").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
' ******************
Dim patternRef As String
Dim patternDemandeur As String
Dim patternNumero As String
Dim patternDescriptionPanne As String
Dim patternAdresse As String
Dim patternDomaine As String
Dim patternStatut As String
Dim patternMotifDemande As String
item.UnRead = False
patternRef = "Numéro de la demande[\r\n]+([^\r\n]+)"
patternDemandeur = "Emetteur[\r\n]+([^\r\n]+)"
patternNumero = "N° tel de l'émetteur de la demande[\r\n]+([^\r\n]+)"
patternDescriptionPanne = "Commentaires initial[\r\n]+([^\r\n]+)"
patternAdresse = "Localisation de la demande[\r\n]+([^\r\n]+)"
patternDomaine = "Famille motif[\r\n]+([^\r\n]+)"
patternStatut = "Statut[\r\n]+([^\r\n]+)"
patternMotifDemande = "Motif de la demande[\r\n]+([^\r\n]+)"
' Creation des differentes variables récuperées dans l'émail de base
Dim sText As String 'Variable qui reprendra le corps de l'émail reçu.
Dim xText As String 'Variable reférence de la demande.
Dim yText As String 'Variable reférence du demandeur.
Dim zText As String 'Variable reférence du numero de telephone.
Dim dText As String 'Variable reférence de la description de la panne.
Dim aText As String 'Variable reférence de l'adresse.
Dim bText As String 'Variable reférence du domaine d'intervention.
Dim cText As String 'Variable reférence du statut fournit par l'entreprise.
Dim oText As String 'Variable reférence du motif de la demande.
sText = Msg.Body ' affectation de la variable
xText = TestRegExp(sText, patternRef, 0)
yText = TestRegExp(sText, patternDemandeur, 0)
zText = TestRegExp(sText, patternNumero, 0)
dText = TestRegExp(sText, patternDescriptionPanne, 0)
aText = TestRegExp(sText, patternAdresse, 0)
aText = Left(aText, InStr(1, aText, "-") - 1) 'Permet de supprimer tout les charactères après le tiret. Garde dans le aText, du premier charactere au tiret -1 donc sans le tiret.
oText = TestRegExp(sText, patternMotifDemande, 0)
bText = TestRegExp(sText, patternDomaine, 1)
cText = TestRegExp(sText, patternStatut, 0)
Dim NewMail As MailItem ' nouvel email
Dim obApp As Object
Set obApp = Outlook.Application
Set NewMail = obApp.CreateItem(olMailItem) 'ces 3 lignes creent le mail.
With NewMail 'remplissage du mail
.Subject = "Domain"
.To = "email"
.Body = "REF=" & xText & vbCrLf & "DOM=" & bText & vbCrLf & "OBJ=" & aText & vbCrLf & "DEMANDE D'INTERVENTION : " & oText & vbCrLf & dText & vbCrLf & "Appelant : " & yText & " / " & zText
.Importance = olImportanceHigh
End With
NewMail.Send
End If
End Sub
Function TestRegExp(myString As String, pattern As String, casDomaine As Integer)
'Create objects.
Dim objRegExp As RegExp
Dim objMatch As Match
Dim colMatches As MatchCollection
Dim RetStr As String
Dim result As String
Dim resultPrep As String
' Create a regular expression object.
Set objRegExp = New RegExp
'Set the pattern by the Pattern property.
objRegExp.pattern = pattern
' Set Case Insensitivity.
objRegExp.IgnoreCase = True
'Set global applicability.
objRegExp.Global = True
'Test whether the String can be compared.
If (objRegExp.Test(myString) = True) Then
'Get the matches.
Set colMatches = objRegExp.Execute(myString) ' Execute search.
If (objRegExp.Test(myString) = True) Then
'Get the matches.
Set colMatches = objRegExp.Execute(myString) ' Execute search.
For Each objMatch In colMatches ' Iterate Matches collection.
If casDomaine = 0 Then
result = objMatch.SubMatches(0)
End If
If casDomaine = 1 Then
'Idealement ne demander que si le texte contient un mot clé pour éviter les erreurs de typo. Resolu par utilisation de conditions, à tester avec Case
' Select Case objMatch.SubMatches(0)
If trouverMotDomaine(LCase(objMatch.SubMatches(0)), LCase("Faible")) Then
' "Electricité (C.Faible)"
result = "28"
ElseIf trouverMotDomaine(LCase(objMatch.SubMatches(0)), LCase("Fort")) Then
' "Electricité (C.Fort)"
result = "27"
ElseIf trouverMotDomaine(LCase(objMatch.SubMatches(0)), LCase("Plomberie")) Or trouverMotDomaine(LCase(objMatch.SubMatches(0)), LCase("Sanitaire")) Then
' "Plomberie / Sanitaire" / essayer d'eviter de lancer 2 cases (FaT)
result = "30"
ElseIf trouverMotDomaine(LCase(objMatch.SubMatches(0)), LCase("Clim")) Or trouverMotDomaine(LCase(objMatch.SubMatches(0)), LCase("Chauf")) Or trouverMotDomaine(LCase(objMatch.SubMatches(0)), LCase("Ventil")) Then
' "Clim / Chauf / Ventil"
result = "24"
ElseIf trouverMotDomaine(LCase(objMatch.SubMatches(0)), LCase("Sécurité")) Or trouverMotDomaine(LCase(objMatch.SubMatches(0)), LCase("Incendie")) Then
' "Sécurité / Incendie"
result = "32"
Else
result = "3"
End If
End If
Next
End If
End If
TestRegExp = result
'Affichage de chaque resultat pour la phase test
' MsgBox result // Affiche resultat à chaque fois pour les phases de test.
End Function
Function trouverMotDomaine(domaine As String, motCle As String) As Boolean
Dim intPos As Integer
intPos = 0
intPos = InStr(domaine, motCle)
trouverMotDomaine = intPos > 0
End Function
You can try using the .display message and then close .olDiscard immediately.
For more information, please see the following link:
VBA Outlook 2010 received mail .Body is empty
i 'm trying to make this program to not only convert positive numbers, but also negative ones. Based on this code, what can I modify so it also convert negative decimal numbers to octo? Also, what can I do if I also want to it convert non-rounded numbers into binary? For example 321.123 to binary.
Private Sub Conversion_Click()
Dim chiffreentrer As Integer
Dim reste As Integer
Dim reste2 As String
Dim chiffreocto As String
chiffreentrer = CInt(InputBox("Entrez un chiffre decimal:", "Conversion Decimal a Octo"))
Do While chiffreentrer >= 1
reste = chiffreentrer Mod 8
reste2 = CStr(reste)
chiffreentrer = chiffreentrer \ 8
chiffreocto = reste & chiffreocto
Loop
MsgBox "Le chiffre en octo est de : " & chiffreocto, , "Conversion Decimal a Octo"
End Sub
--
Public Function Division(Nombre As Integer)
i = 1
j = 1
Bla = ""
Nbinit = Nombre
reste = 0
ActiveSheet.Cells(i, 1) = Nombre
ActiveSheet.Cells(i, 2) = "÷2"
ActiveSheet.Cells(i, 2).HorizontalAlignment = xlRight
Do
reste = (Nombre - 2 * Int(Nombre / 2))
Nombre = Int(Nombre / 2)
Bla = reste & Bla
i = i + 1
ActiveSheet.Cells(i, 1) = Nombre
ActiveSheet.Cells(i, 2) = reste
Loop While (Nombre > 0)
MsgBox "Le nombre " & Nbinit & " est équivalent à " & Bla & " en binaire"
End Function
Try this:
Private Sub Conversion_Click()
Dim chiffreentrer As Integer
Dim reste As Integer
Dim reste2 As String
Dim chiffreocto As String
chiffreentrer = CInt(InputBox("Entrez un chiffre decimal:", "Conversion Decimal a Octo"))
Do While chiffreentrer >= 1 Or chiffreentrer <= -1
reste = chiffreentrer Mod 8
reste2 = CStr(reste)
chiffreentrer = chiffreentrer \ 8
If Left(chiffreocto, 1) = "-" Then chiffreocto = Mid(chiffreocto, 2)
chiffreocto = reste & chiffreocto
Loop
MsgBox "Le chiffre en octo est de : " & chiffreocto, , "Conversion Decimal a Octo"
End Sub
I made this macro to highlight the same values in the same worksheet but I would like it to go one by one not highlight all numbers at once.
Sub series()
'Definición de variables
Dim rango As String
Dim valor As String
Dim resultado As Range
Dim primerResultado As String
Dim cont As Integer
'Solicitar información al usuario
rango = "A1:XFD1048576"
valor = InputBox("Ingresa el VALOR a buscar:")
If valor = "" Then Exit Sub
'Inicializar contador de coincidencias
cont = 0 'Primera búsqueda del valor dentro del rango
Set resultado = Range(rango).Find(What:=valor, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not resultado Is Nothing Then 'Si el resultado de la búsqueda no es vacío
primerResultado = resultado.Address
Do 'Inicia bucle para hacer varias búsquedas
cont = cont + 1
resultado.Interior.ColorIndex = 4 'Cambia el color de fondo de la celda
Set resultado = Range(rango).FindNext(resultado) 'Vuelve a buscar el valor
Loop While Not resultado Is Nothing And resultado.Address <> primerResultado
Else
cont = 0
MsgBox "Se encontraron " & cont & " coincidencias."
'valor = InputBox("Ingresa el VALOR a buscar:")
End If
Application.Run ("series")
'valor = InputBox("Ingresa el VALOR a buscar:")
'Muestra un cuadro de diálogo con el número de coincidencias
'MsgBox "Se encontraron " & cont & " coincidencias."
End Sub
This will ask confirmation from the user to highlight each cell found (untested)
Option Explicit
Public Sub series()
'Definición de variables (Definition of variables)
Dim rango As String, valor As String, resultado As Range
Dim primerResultado As String, cont As Integer
'Solicitar información al usuario (Get information from the user)
rango = ActiveSheet.UsedRange
valor = InputBox("Ingresa el VALOR a buscar:")
If valor = "" Then Exit Sub
cont = 0 'Inicializar contador de coincidencias (Initialize Find)
'Primera búsqueda del valor dentro del rango (First search for value in the range)
Set resultado = Range(rango).Find(What:=valor, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not resultado Is Nothing Then 'Si el resultado de la búsqueda no es vacío
primerResultado = resultado.Address
Do 'Inicia bucle para hacer varias búsquedas
If MsgBox("Resaltar celular?", vbYesNo) = vbYes Then
cont = cont + 1
resultado.Interior.ColorIndex = 4 'Cambia el color de fondo de la celda
End If
Set resultado = Range(rango).FindNext(resultado) 'Vuelve a buscar el valor
Loop While Not resultado Is Nothing And resultado.Address <> primerResultado
Else
MsgBox "Se encontraron " & cont & " coincidencias."
End If
End Sub