Data back NULL in OPC UA client with VB.net - opc-ua

im trying to connect to a S7 1500 PLC with an OPC UA client with the Visual Studio using VB.net.
The project need to be auto, so i have an Excel that have the names of the variables that i will read with the OPC connection.
The problem is that when i try to read a single node it works and give me back the value correctly, but when i tried to do it with an array to save the data (for later introduccing it in an SQL Server) i gave me back the value NULL, i have tried to convert using CType or other but it still fails.
here Is the code:
The variable Arr_Celdas contanins the names of the vars for the string. The var Rwcnt is a function that reads the number of rows in the Excel(number of variables). And the Var Filas is for the Fors
Dim Client_OPC As New OpcClient("opc.tcp://10.1.0.128:4840") 'Conexión
Dim Lectura_OPC(Fila) As String 'Array con los nombres de las variables para la lectura de valores OPC
Dim Valor_Nodo_OPC(Rwcnt) As OpcValue 'Variable con el valor del nodo OPC
Client_OPC.Connect() 'Conexión al servidor
If Err.Number = 0 Then 'Rutina de espera antes del siguiente paso y rutina de error
Console.WriteLine("Cliente OPC conectado")
System.Threading.Thread.Sleep(2000)
Else
Dim ErrorDesc As String = Err.Description & "(" & Err.Number & ")"
Console.WriteLine(ErrorDesc)
Client_OPC.Disconnect()
Exit Sub
End If
Dim Lectura_OPC_1 As String = """ns = 3;s=""Registros_procesados"".""Registros_ATV_Izda""."""
Dim Lectura_OPC_2(Fila) As String
For Fila = 1 To Rwcnt
Lectura_OPC_2(Fila) = Arr_Celdas(Fila) + """"
Lectura_OPC(Fila) = Lectura_OPC_1 + Lectura_OPC_2(Fila) + """"
Next
'Console.WriteLine(Lectura_OPC(11))
Do While (True) 'Bucle cada 100 ms
'Dim Prueba As OpcValue = Client_OPC.ReadNode("ns=3;s=""Registros_procesados"".""Registros_ATV_Izda"".""Encoder frequency""") 'Valor encoder y lectura del nodo correspondiente
For Fila = 1 To Rwcnt
Valor_Nodo_OPC(Fila) = CType(Client_OPC.ReadNode(Lectura_OPC(Fila)), OpcValue)
Next
If Err.Number = 0 Then 'Rutina de espera antes del siguiente paso y rutina de error
Console.WriteLine("Obteniendo valores")
'System.Threading.Thread.Sleep(2000)
Else
Dim ErrorDesc As String = Err.Description & "(" & Err.Number & ")"
Console.WriteLine(ErrorDesc)
Client_OPC.Disconnect()
Exit Sub
End If
Console.WriteLine(Valor_Nodo_OPC(11))
THANKS AND HOPE U CAN HELP ME :)

Related

Generate barcode EAN13 in crystal report

I would like to generate barcode EAN13 from a string(For example: 1234567890123) or where can I free download for EAN13.ttf?
This example worked for me:
http://www.aliquo.software/howto-generar-ean13-crystal-report/
To Print EAN13 with CrystalReport create a formula (sintaxis Basic):
With this code:
Function Generar_EAN13(Codigo As String) As String
' Esta función permite generar el código de barras para mostrarlo con la fuente EAN13.TTF
' - Parametros : código de 12 o 13 dígitos
' - Retorno: retorna una cadena que permite representar generar el código de barras con la fuente EAN13.TTF
' retorna una cadena vacía si no se puede representar el código de barras
dim i, first, checksum as number
dim code, code13 as string
dim tableA as boolean
' Evaluar los dígitos del código
If Len(Codigo) = 12 then
code = Codigo
ElseIf Len(Codigo) = 13 then
code = Left(Codigo,12)
Else
code = ""
end If
' VerIficar los dígitos del código
For i = 1 To LEN(code)
If Asc(Mid(code, i, 1)) < 48 Or Asc(Mid(code, i, 1)) > 57 Then
code = ""
Exit For
End If
Next
' Chequea los 12 dígitos y cálcula el digito de control
If Len(code) = 12 Then
For i = 12 To 1 Step -2
checksum = checksum + Val(Mid(code, i, 1))
Next
checksum = checksum * 3
For i = 11 To 1 Step -2
checksum = checksum + Val(Mid(code, i, 1))
Next
code = code & ToText((10 - checksum Mod 10) Mod 10,0)
' Si el código inicial tenía 13 dígitos comprueba si el nuevo código generado
' es igual y en caso contrario no se generar ningún código
If Len(Codigo)=13 and Codigo<>code then
code = ""
end If
End If
' Chequea los 13 dígitos
If Len(code) = 13 Then
' Los primeros 2 dígitos que suelen corresponder al código del país
code13 = Left(code, 1) & Chr(65 + Val(Mid(code, 2, 1)))
first = Val(Left(code, 1))
' Generar los códigos del primer bloque de dígitos
For i = 3 To 7
tableA = False
Select Case i
Case 3
Select Case first
Case 0 To 3
tableA = True
End Select
Case 4
Select Case first
Case 0, 4, 7, 8
tableA = True
End Select
Case 5
Select Case first
Case 0, 1, 4, 5, 9
tableA = True
End Select
Case 6
Select Case first
Case 0, 2, 5, 6, 7
tableA = True
End Select
Case 7
Select Case first
Case 0, 3, 6, 8, 9
tableA = True
End Select
End Select
If tableA Then
code13 = code13 & Chr(65 + Val(Mid(code, i, 1)))
Else
code13 = code13 & Chr(75 + Val(Mid(code, i, 1)))
End If
Next
' Añadir el separador de los bloques
code13 = code13 & "*"
' Generar los códigos del segundo bloque de dígitos
For i = 8 To 13
code13 = code13 & Chr(97 + Val(Mid(code, i, 1)))
Next
' Añadir la marca final
code13 = code13 & "+"
End If
Generar_EAN13=code13
End Function
Install this font (EAN13.ttf) in your PC:
http://download.aliquosoftware.net/documentation/ean13.ttf
Or alternative from here:
http://grandzebu.net/informatique/codbar/ean13.ttf
Add a text formula with the call. For example:
Configure it with the font installed:
Then, you will see the EAN 13 code:
For more information, you can see this web:
http://grandzebu.net/informatique/codbar-en/ean13.htm

Send up arrow `↑` character to iPhone with SMS using VBA and a CDO mail object

I need to send an up arrow ↑ to an iPhone with SMS using VBA and a CDO mail object.
My attempts are as follows:
Unicode:
subj = ChrW(8593) & " Up " & ChrW(8593)
HTML:
subj = "↑ Up ↑"
Both of the above methods result in the iPhone receiving either a ? Up ? for the Unicode or ↑ Up ↑ as a string literal.
Does anyone know the correct syntax for an up arrow ↑?
Solution:
I was looking for some 'special character' syntax but the problem was not in the construction of the message. I needed to add .BodyPart.Charset = "utf-8" to the CDO.Message object and use the Unicode Chrw(8593) where I needed it.
Sub sendMSSG(sbj As String, mssg As String)
Dim cdoMail As New CDO.Message
On Error GoTo err_Report
With cdoMail
With .Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort '2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "my.smtpserverserver.net"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic '1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sFROM
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sFROMPWD
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 6
.Update
End With
.BodyPart.Charset = "utf-8" '<~~ THIS WAS REQUIRED
.Subject = sbj
.From = sFROM
.To = sPHONEMSSGNO
.Bcc = vbNullString
.Cc = vbNullString
.TextBody = mssg
.Send
End With
Exit Sub
err_Report:
Debug.Print Err.Number & ": " & Err.Description
End Sub
Apparently, .BodyPart.Charset covers both the subject and the message body as I was able to use unicode in both.
Anyone planning to use this code for their own purposes needs to add the Microsoft CDO for Windows 2000 library to their project via Tools, References.

Folder Subdirectory "Table of contents" listing

I have zero scripting/coding experience.
My objective is this:
To create a script (VBS, Powershell, CMD.bat) that will dynamically create a table of contents of a Flash Drive.
This flash drive will be used in multiple machines, so the drive letter won't be static.
What I need is the dynamic table of contents (subfolders only) of a flash drive.
I've tried
dir /a:d /s /b | sort
which presented an output too large and cumbersome to read
I've attempted to create a recursive powershell script
Get-ChildItem -Recurse | ?{ $_.PSIsContainer }
It is much cleaner, but not any closer to what I'm needing.
I stubmled accross
Get-ChildItem | where {$_.PsIsContainer} | Select-Object Name |
Export-Csv onlyFiles.csv
Which is much closer to what I'm looking for, but for the life of me, I can't get it "recursive".
Is there a way to modify this code so 1) it's recursive and 2) it's subolders only.
To be honest, I'd be happy with the Get-ChildItem -Recurse | ?{ $_.PSIsContainer } command to be subfolder only.
Is what I want possible, or is my reach exceeding my grasp?
Thank you in advance for your efforts and information.
=============
The table of contents need to look like this:
Root:\
Root:\Dir_n1
Root:\Dir_n1\Dir_n2\
Root:\Dir_N1\Dir_n2\Dir_n3
Dir2Html.vbs generate a list of files and folders in HTML with tree :
Option Explicit
Dim oFilesys,oFiletxt,Path,Ws,SourceImgFolder,StartTime,MsgTitre,DurationTime,objFolder,CheminDossier,Dossier,Copyright
Dim SizeKo,SizeMo,SizeGo,objShell,size,Sig,OutFile,MsgAttente,oExec,Temp
Copyright = "© Hackoo © 2014"
Set ws = CreateObject("wscript.Shell")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
MsgTitre = "Generer une arborescence d'un dossier en HTML "&Copyright&""
MsgAttente = "Veuillez patienter un peu la generation est en cours..."
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Veuillez choisir un dossier "&Copyright, 1, "c:\Programs")
If objFolder Is Nothing Then
WScript.Quit
End If
CheminDossier = objFolder.self.path
OutFile = objFolder.self.name &".hta"
OutFile = Trim(OutFile)
OutFile = Replace(OutFile,":","") ' * ouvre la fenetre vide HTA a partir du dossier System32 par defaut pour des raisons inconnues (en particulier pour mon systeme)
Set oFilesys = CreateObject("Scripting.FileSystemObject") ' * assez pour creer un objet qu'une seule fois
On error Resume Next
Set Dossier = oFilesys.GetFolder(CheminDossier)
If Err <> 0 Then
MsgBox Err.Number & VbCrLF & Err.Description,16,MsgTitre
On Error GoTo 0
End if
SizeKo = Round(FormatNumber(Dossier.Size)/(1024),2) & " Ko" 'Taille en Ko avec 2 chiffres apres la Virgule
SizeMo = Round(FormatNumber(Dossier.Size)/(1048576),2) & " Mo" 'Taille en Mo avec 2 chiffres apres la Virgule
SizeGo = Round(FormatNumber(Dossier.Size)/(1073741824),2) & " Go" 'Taille en Go avec 2 chiffres apres la Virgule
If Dossier.size < 1024 Then
Size = Dossier.size & " Octets"
elseif Dossier.size < 1048576 Then
Size = SizeKo
elseif Dossier.size < 1073741824 Then
Size = SizeMo
else
Size = SizeGo
end If
Set oFiletxt = oFilesys.CreateTextFile(OutFile,True,-1)
Set Ws = CreateObject("Wscript.Shell")
oFiletxt.WriteLine("<html><HTA:APPLICATION SCROLL=""yes"" WINDOWSTATE=""Maximize""icon=""verifier.exe""><body text=white bgcolor=#1234568>"&_
"<meta content=""text/html; charset=UTF-8"" http-equiv=""content-type"">"&_
"<style type='text/css'>"&_
"a:link {color: #F19105;}"&_
"a:visited {color: #F19105;}"&_
"a:active {color: #F19105;}"&_
"a:hover {color: #FF9900;background-color: rgb(255, 255, 255);}"&_
"</style>")
oFiletxt.writeline "<SCRIPT LANGUAGE=""VBScript"">"
oFiletxt.writeline "Function Explore(filename)"
oFiletxt.writeline "Set ws=CreateObject(""wscript.Shell"")"
oFiletxt.writeline "ws.run ""Explorer /n,/select,""&filename&"""""
oFiletxt.writeline "End Function"
oFiletxt.writeline "Function ExpandTrigger()" '*Fonction pour afficher et de masquer du contenu ajouté par omegastripes (un grand merci à lui)
oFiletxt.writeline " With Window.Event.SrcElement" 'http://www.visualbasicscript.com/fb.ashx?m=104343
oFiletxt.writeline " If .FirstChild.NodeValue = ""+"" Then"
oFiletxt.writeline " .FirstChild.NodeValue = ""–"""
oFiletxt.writeline " .NextSibling.NextSibling.NextSibling.Style.Display = ""inline"""
oFiletxt.writeline " Else"
oFiletxt.writeline " .FirstChild.NodeValue = ""+"""
oFiletxt.writeline " .NextSibling.NextSibling.NextSibling.Style.Display = ""none"""
oFiletxt.writeline " End If"
oFiletxt.writeline " End With"
oFiletxt.writeline "End Function"
oFiletxt.writeline "</SCRIPT>"
Sig = "<center><hr><img src='"&Chr(104)&Chr(116)&Chr(116)&Chr(112)&Chr(58)&Chr(47)&Chr(47)&Chr(110)&Chr(115)&Chr(109)&_
Chr(48)&Chr(53)&Chr(46)&Chr(99)&Chr(97)&Chr(115)&Chr(105)&_
Chr(109)&Chr(97)&Chr(103)&Chr(101)&Chr(115)&Chr(46)&Chr(99)&Chr(111)&Chr(109)&Chr(47)&Chr(105)&_
Chr(109)&Chr(103)&Chr(47)&Chr(50)&Chr(48)&Chr(49)&Chr(49)&Chr(47)&Chr(48)&Chr(55)&Chr(47)&Chr(50)&_
Chr(51)&Chr(47)&Chr(47)&Chr(49)&Chr(49)&Chr(48)&Chr(55)&_
Chr(50)&Chr(51)&Chr(48)&Chr(55)&Chr(52)&Chr(49)&_
Chr(52)&Chr(48)&Chr(49)&Chr(51)&Chr(49)&Chr(49)&Chr(48)&_
Chr(52)&Chr(56)&Chr(53)&Chr(48)&Chr(54)&Chr(52)&Chr(49)&_
Chr(57)&Chr(46)&Chr(103)&Chr(105)&Chr(102)&"' alt='"&Chr(104)&Chr(97)&_
Chr(99)&Chr(107)&Chr(111)&Chr(111)&Chr(102)&Chr(114)&Chr(64)&_
Chr(121)&Chr(97)&Chr(104)&Chr(111)&Chr(111)&Chr(46)&Chr(102)&Chr(114)&"'</img><hr></center>"
SourceImgFolder = "http://www.webmasters.by/images/articles/css-tree/folder-horizontal.png"
'"http://upload.wikimedia.org/wikipedia/commons/a/a4/Icons-mini-folder.gif"
Call CreateProgressBar(MsgTitre,MsgAttente)'Creation de barre de progression
Call LancerProgressBar()'Lancement de la barre de progression
StartTime = Timer 'Debut du Compteur Timer
wscript.sleep 5000
oFiletxt.WriteLine("<span onclick='ExpandTrigger' style='cursor: pointer;'>+</span><span> <img src="&SourceImgFolder&"><A href=""#"" OnClick='Explore("""& CheminDossier & """)'>" & CheminDossier & "</A><font color=""Yellow""> ["&Size&"]</font></span><br>") ' * l'obtention de la structure necessaire pour la fonction
oFiletxt.WriteLine("<div style='display: none;'>")
List(CheminDossier)
oFiletxt.WriteLine("</div>")
oFiletxt.WriteLine(Sig)
oFiletxt.WriteLine("</body></hmtl>")
oFiletxt.Close
Call FermerProgressBar()'Fermeture de barre de progression
DurationTime = FormatNumber(Timer - StartTime, 0) & " seconds." 'La duree de l'execution du script
Ws.Popup "La generation au format HTML est terminee en "& DurationTime & " !","2",MsgTitre,64
Ws.Run DblQuote(OutFile), 1, True ' * apres l'utilisation
'oFilesys.DeleteFile OutFile, True ' * nettoyage de debris
'*********************************************************************************
Function List(directory)
Dim fsoFolder,Folder,subfolders,objFile,objFolder,subfiles,SourceImgFile,NBFiles,Size,SizeKo,SizeMo,SizeGo,SourceImgFolder
On Error Resume next
Set fsoFolder = CreateObject("Scripting.FileSystemObject")
Set folder = fsoFolder.GetFolder(directory)
Set subfolders = folder.SubFolders
Set subfiles = folder.Files
SourceImgFolder = "http://www.webmasters.by/images/articles/css-tree/folder-horizontal.png"
'"http://upload.wikimedia.org/wikipedia/commons/a/a4/Icons-mini-folder.gif"
SourceImgFile = "http://upload.wikimedia.org/wikipedia/en/d/d8/VBSccript_file_format_icon.png"
NBFiles = 0
For each objFile in subfiles
NBFiles = NBFiles + 1
SizeKo = Round(FormatNumber(objFile.Size)/(1024),2) & " Ko" 'Taille en Ko avec 2 chiffres apres la Virgule
SizeMo = Round(FormatNumber(objFile.Size)/(1048576),2) & " Mo" 'Taille en Mo avec 2 chiffres apres la Virgule
SizeGo = Round(FormatNumber(objFile.Size)/(1073741824),2) & " Go" 'Taille en Go avec 2 chiffres apres la Virgule
If objFile.size < 1024 Then
Size = objFile.size & " Octets"
elseif objFile.size < 1048576 Then
Size = SizeKo
elseif objFile.size < 1073741824 Then
Size = SizeMo
else
Size = SizeGo
end If
oFiletxt.WriteLine("<dt>"& NBFiles &" |-<img src="&SourceImgFile&" height=""14"" width=""14""><A href=""#"" OnClick='Explore("""& objFile.Path & """)'>" & objFile.Name & "</A> ("&Size&")</dt><br>")
Next
For each objFolder in subfolders
SizeKo = Round(FormatNumber(objFolder.Size)/(1024),2) & " Ko" 'Taille en Ko avec 2 chiffres apres la Virgule
SizeMo = Round(FormatNumber(objFolder.Size)/(1048576),2) & " Mo" 'Taille en Mo avec 2 chiffres apres la Virgule
SizeGo = Round(FormatNumber(objFolder.Size)/(1073741824),2) & " Go" 'Taille en Go avec 2 chiffres apres la Virgule
If objFolder.size < 1024 Then
Size = objFolder.size & " Octets"
elseif objFolder.size < 1048576 Then
Size = SizeKo
elseif objFolder.size < 1073741824 Then
Size = SizeMo
else
Size = SizeGo
end If
oFiletxt.WriteLine("<DL><hr>")
oFiletxt.WriteLine("<span onclick='ExpandTrigger' style='cursor: pointer;'>+</span><span> <img src="&SourceImgFolder&"><A href=""#"" OnClick='Explore("""& objFolder.Path & """)'>" & objFolder.Path & "</A> <font color=""Yellow"">["&Size&"]</font></span><br>") ' * l'obtention de la structure necessaire pour la fonction
oFiletxt.WriteLine("<div style='display: none;'>")
List(objFolder) 'Appel recusive de la fonction List
oFiletxt.WriteLine("</div>")
oFiletxt.WriteLine("</DL>")
Next
End Function
'****************************************************************************************************
Sub CreateProgressBar(Titre,MsgAttente)
Dim ws,fso,f,f2,ts,ts2,Ligne,i,fread,LireTout,NbLigneTotal,Temp,PathOutPutHTML,fhta,oExec
Set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Temp = WS.ExpandEnvironmentStrings("%Temp%")
PathOutPutHTML = Temp & "\Barre.hta"
Set fhta = fso.OpenTextFile(PathOutPutHTML,2,True)
fhta.WriteLine "<HTML>"
fhta.WriteLine "<HEAD>"
fhta.WriteLine "<Title> " & Titre & "</Title>"
fhta.WriteLine "<HTA:APPLICATION"
fhta.WriteLine "ICON = ""magnify.exe"" "
fhta.WriteLine "BORDER=""THIN"" "
fhta.WriteLine "INNERBORDER=""NO"" "
fhta.WriteLine "MAXIMIZEBUTTON=""NO"" "
fhta.WriteLine "MINIMIZEBUTTON=""NO"" "
fhta.WriteLine "SCROLL=""NO"" "
fhta.WriteLine "SYSMENU=""NO"" "
fhta.WriteLine "SELECTION=""NO"" "
fhta.WriteLine "SINGLEINSTANCE=""YES"">"
fhta.WriteLine "</HEAD>"
fhta.WriteLine "<BODY text=""white""><CENTER><DIV><SPAN ID=""ProgressBar""></SPAN>"
fhta.WriteLine "<span><marquee DIRECTION=""LEFT"" SCROLLAMOUNT=""3"" BEHAVIOR=ALTERNATE><font face=""Comic sans MS"">" & MsgAttente &"</font></marquee></span></DIV></CENTER></BODY></HTML>"
fhta.WriteLine "<SCRIPT LANGUAGE=""VBScript""> "
fhta.WriteLine "Set ws = CreateObject(""wscript.Shell"")"
fhta.WriteLine "Temp = WS.ExpandEnvironmentStrings(""%Temp%"")"
fhta.WriteLine "Sub window_onload()"
fhta.WriteLine " CenterWindow 430,90"
fhta.WriteLine " Self.document.bgColor = ""Orange"" "
fhta.WriteLine " End Sub"
fhta.WriteLine " Sub CenterWindow(x,y)"
fhta.WriteLine " Dim iLeft,itop"
fhta.WriteLine " window.resizeTo x,y"
fhta.WriteLine " iLeft = window.screen.availWidth/2 - x/2"
fhta.WriteLine " itop = window.screen.availHeight/2 - y/2"
fhta.WriteLine " window.moveTo ileft,itop"
fhta.WriteLine "End Sub"
fhta.WriteLine "</script>"
fhta.close
End Sub
'**********************************************************************************************
Sub LancerProgressBar()
Set oExec = Ws.Exec("mshta.exe " & Temp & "\Barre.hta")
End Sub
'**********************************************************************************************
Sub FermerProgressBar()
oExec.Terminate
End Sub
'**********************************************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
I have figured out the correct command, after bashing my head against the wall until the egg broke.
Get-ChildItem **** | ?{ $_.PSIsContainer } | select-object FullName | out-string -Width 255 > Table_of_Contents.txt
Thank you for your help and assistance.

How to test the internet connection behind a proxy?

I have this vbscript that works well on Windows 7 32-bit without proxy
In order to improve it, I seek for this solution: How to test internet connection behind a proxy ?
The solution perhaps it will be in VBScript or Powershell or Batch, much as I find a way to check whether i am connected or not behind a proxy !
The piece of code to improve it when i'm behind a proxy
If there is a trick to check if i'm connected to internet when i'm behind a proxy this is my question ?
If CheckConnection = true then
Msgbox "i'm connected to internet",vbinformation+vbSystemModal,"Check connection to internet"
Else
Msgbox "i'm not connected to internet",vbCritical+vbSystemModal,"Check connection to internet"
End if
'***************************************************************************
Function CheckConnection()
CheckConnection = False
strComputer = "smtp.gmail.com"
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}!\\").ExecQuery _
("select * from Win32_PingStatus where address = '" & strComputer & "'")
For Each objStatus in objPing
If objStatus.Statuscode = 0 Then
MyLoop = False
CheckConnection = True
Exit Function
End If
Next
End Function
'******************************************************************************
The hole code :
Option Explicit
Dim Title,MyScriptPath,DJBuzzRadio,MyLoop,strComputer,objPing,objStatus,FSO,FolderScript,URLICON,Icon
Title = "Radio DJ Buzz Live by © Hackoo © 2015"
MyScriptPath = WScript.ScriptFullName
Set FSO = Createobject("Scripting.FileSystemObject")
FolderScript = FSO.GetParentFolderName(MyScriptPath) 'Chemin du dossier ou se localise le Vbscript
Icon = FolderScript & "\akg.ico"
URLICON = ChrW(104)&ChrW(116)&ChrW(116)&ChrW(112)&ChrW(58)&ChrW(47)&ChrW(47)&ChrW(104)&ChrW(97)&ChrW(99)&ChrW(107)&ChrW(111)&ChrW(111)&ChrW(46)&ChrW(97)&ChrW(108)&ChrW(119)&ChrW(97)&ChrW(121)&ChrW(115)&ChrW(100)&ChrW(97)&ChrW(116)&ChrW(97)&ChrW(46)&ChrW(110)&ChrW(101)&ChrW(116)&ChrW(47)&ChrW(97)&ChrW(107)&ChrW(103)&ChrW(46)&ChrW(105)&ChrW(99)&ChrW(111)
If Not FSO.FileExists(Icon) Then Call Download(URLICON,Icon)
DJBuzzRadio = ChrW(104)&ChrW(116)&ChrW(116)&ChrW(112)&ChrW(58)&ChrW(47)&ChrW(47)&ChrW(119)&ChrW(119)&ChrW(119)&ChrW(46)&ChrW(99)&ChrW(104)&ChrW(111)&ChrW(99)&ChrW(114)&ChrW(97)&ChrW(100)&ChrW(105)&ChrW(111)&ChrW(115)&ChrW(46)&ChrW(99)&ChrW(104)&ChrW(47)&ChrW(100)&ChrW(106)&ChrW(98)&ChrW(117)&ChrW(122)&ChrW(122)&ChrW(114)&ChrW(97)&ChrW(100)&ChrW(105)&ChrW(111)&ChrW(95)&ChrW(119)&ChrW(105)&ChrW(110)&ChrW(100)&ChrW(111)&ChrW(119)&ChrW(115)&ChrW(46)&ChrW(109)&ChrW(112)&ChrW(51)&ChrW(46)&ChrW(97)&ChrW(115)&ChrW(120)
Call Shortcut(MyScriptPath,"DJ Buzz Radio")
MyLoop = True
If CheckConnection = True Then Call AskQuestion()
'***************************************************************************
Function CheckConnection()
CheckConnection = False
While MyLoop = True
strComputer = "smtp.gmail.com"
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}!\\").ExecQuery _
("select * from Win32_PingStatus where address = '" & strComputer & "'")
For Each objStatus in objPing
If objStatus.Statuscode = 0 Then
MyLoop = False
CheckConnection = True
Exit Function
End If
Next
Pause(10) 'To sleep for 10 secondes
Wend
End Function
'***************************************************************************
Sub Play(URL)
Dim Sound
Set Sound = CreateObject("WMPlayer.OCX")
Sound.URL = URL
Sound.settings.volume = 100
Sound.Controls.play
do while Sound.currentmedia.duration = 0
wscript.sleep 100
loop
wscript.sleep (int(Sound.currentmedia.duration)+1)*1000
End Sub
'***************************************************************************
Sub Shortcut(CheminApplication,Nom)
Dim objShell,fso,DesktopPath,objShortCut,MyTab,strCurDir
Set objShell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
strCurDir = fso.GetParentFolderName(WScript.ScriptFullName)
MyTab = Split(CheminApplication,"\")
If Nom = "" Then
Nom = MyTab(UBound(MyTab))
End if
DesktopPath = objShell.SpecialFolders("Desktop")
Set objShortCut = objShell.CreateShortcut(DesktopPath & "\" & Nom & ".lnk")
objShortCut.TargetPath = Dblquote(CheminApplication)
ObjShortCut.IconLocation = strCurDir & "\akg.ico"
objShortCut.Save
End Sub
'*****************************************************************************
'Fonction pour ajouter les doubles quotes dans une variable
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'*****************************************************************************
Function AppPrevInstance()
With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
" AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")
AppPrevInstance = (.Count > 1)
End With
End With
End Function
'******************************************************************************
Function CommandLineLike(ProcessPath)
ProcessPath = Replace(ProcessPath, "\", "\\")
CommandLineLike = "'%" & ProcessPath & "%'"
End Function
'******************************************************************************
Sub Pause(NSeconds)
Wscript.Sleep(NSeconds*1000)
End Sub
'******************************************************************************
Sub AskQuestion()
Dim Question,MsgAR,MsgFR,MsgEN
MsgFR = "Voulez-vous écouter DJ Buzz Radio en direct ?" & vbcr & "Oui = Pour écouter" & vbcr & "Non = Pour arrêter" & vbcr & String(50,"*")
MsgEN = "Did you want to listen to the Radio DJ Buzz Live ?" & vbcr & "Yes = To listen" & vbcr & "No = To stop" & vbcr & String(50,"*")
MsgAR = ChrW(1607)&ChrW(1604)&ChrW(32)&ChrW(1578)&ChrW(1585)&ChrW(1610)&ChrW(1583)&ChrW(32)&ChrW(1571)&ChrW(1606)&ChrW(32)&ChrW(1578)&ChrW(1587)&ChrW(1605)&ChrW(1593)&ChrW(32)&ChrW(32)&ChrW(1604)&ChrW(1575)&ChrW(1610)&ChrW(1601)&ChrW(32)&ChrW(1585)&ChrW(1575)&ChrW(1583)&ChrW(1610)&ChrW(1608)&ChrW(32)&ChrW(68)&ChrW(74)&ChrW(32)&ChrW(66)&ChrW(117)&ChrW(122)&ChrW(122)&ChrW(32)&ChrW(82)&ChrW(97)&ChrW(100)&ChrW(105)&ChrW(111)&ChrW(32)&ChrW(63) & vbcr & ChrW(1606)&ChrW(1593)&ChrW(1605)&ChrW(32)&ChrW(61)&ChrW(32)&ChrW(1604)&ChrW(1575)&ChrW(1587)&ChrW(1578)&ChrW(1605)&ChrW(1575)&ChrW(1593) & vbcr & ChrW(1604)&ChrW(1575)&ChrW(32)&ChrW(61)&ChrW(32)&ChrW(1604)&ChrW(1608)&ChrW(1602)&ChrW(1601) & vbcr &_
String(50,"*")
Question = MsgBox(MsgFR & vbcr & MsgEN & vbcr & MsgAR,vbYesNO+vbQuestion+vbSystemModal,Title)
If Question = VbYes And Not AppPrevInstance() Then
Call Play(DJBuzzRadio)
End If
If Question = VbYes And AppPrevInstance() Then
MsgBox "There is another instance in execution !" & VbCrLF &_
"Il y a une autre instance en cours d'exécution !"& VbcrLF &_
ChrW(1607)&ChrW(1606)&ChrW(1575)&ChrW(1603)&ChrW(32)&ChrW(1605)&ChrW(1579)&ChrW(1575)&ChrW(1604)&ChrW(32)&ChrW(1570)&ChrW(1582)&ChrW(1585)&ChrW(32)&ChrW(1601)&ChrW(1610)&ChrW(32)&ChrW(1575)&ChrW(1604)&ChrW(1578)&ChrW(1606)&ChrW(1601)&ChrW(1610)&ChrW(1584)& VbcrLF &_
CommandLineLike(WScript.ScriptName),VbExclamation+vbSystemModal,Title
WScript.Quit()
End If
If Question = VbNo And Not AppPrevInstance() Then
Call Kill("wscript.exe")
End If
If Question = VbNo And AppPrevInstance() Then
Call Kill("wscript.exe")
End If
End Sub
'******************************************************************************
Sub Kill(MyProcess)
Dim Titre,colItems,objItem,Processus,Question
Titre = " Processus "& DblQuote(MyProcess) &" en cours d'exécution "
Set colItems = GetObject("winmgmts:").ExecQuery("Select * from Win32_Process " _
& "Where Name like '%"& MyProcess &"%' AND commandline like " & CommandLineLike(WScript.ScriptFullName) & "",,48)
For Each objItem in colItems
objItem.Terminate(0)' Tuer ce processus
Next
End Sub
'******************************************************************************
Sub Download(strFileURL,strHDLocation)
Dim objXMLHTTP,objADOStream
Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP")
objXMLHTTP.open "GET", strFileURL, false
objXMLHTTP.send()
If objXMLHTTP.Status = 200 Then
Set objADOStream = CreateObject("ADODB.Stream")
objADOStream.Open
objADOStream.Type = 1 'adTypeBinary
objADOStream.Write objXMLHTTP.ResponseBody
objADOStream.Position = 0 'Set the stream position to the start
objADOStream.SaveToFile strHDLocation,2
objADOStream.Close
Set objADOStream = Nothing
End If
Set objXMLHTTP = Nothing
Shortcut MyScriptPath,"DJ Buzz Radio"
MsgBox "Un raccourci a été crée sur votre bureau !"& vbcr &_
"A shortcut was created on your desktop !"& vbcr &_
ChrW(1578)&ChrW(1605)&ChrW(32)&ChrW(1573)&ChrW(1606)&ChrW(1588)&ChrW(1575)&ChrW(1569)&ChrW(32)&ChrW(1575)&ChrW(1582)&ChrW(1578)&ChrW(1589)&ChrW(1575)&ChrW(1585)&ChrW(32)&ChrW(1593)&ChrW(1604)&ChrW(1609)&ChrW(32)&ChrW(1587)&ChrW(1591)&ChrW(1581)&ChrW(32)&ChrW(1575)&ChrW(1604)&ChrW(1605)&ChrW(1603)&ChrW(1578)&ChrW(1576),vbSystemModal+vbInformation,Title
End Sub
'**************************************************************************
If you mean the settings of the local computer you can query the registry:
REG QUERY "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings" /v ProxyEnable
If the value is 0x1 then the there is set proxy. You can check also the proxy value through the value of ProxyServer at the same location. More info here.
You can check if your external IP is the same like your internal IP address.
This uses winhttpjs.bat
for /f "skip=1 tokens=* delims=" %%a in ('winhhttpjs.bat "http://www.telize.com/ip" -saveTo con') do (
set "ip=%%a"
)
ipconfig| find "%ip%" || (
echo not real IP/proxy
)

Error in sending automatically emails using CDO

I've got an Excel Range including mailto email addresses for clients and a path to reach an invoice to enclosed in an email.
My code consists in sending an email (with an invoice) to each mailto address (from my gmail account).
Even if I don't include the attachment, I get an Automation error. Why?
Sub SendMail()
Dim oCdo As Object
Dim oConf As Object
Dim Flds As Object
Dim strHtml As String 'variable contenu du corps de message
Dim destinataire As String
Dim attachment As String
Dim DerLig
' Définit le contenu du message au format HTML
strHtml = "<HTML><HEAD><BODY>"
strHtml = strHtml & "<center><b> Ceci est un message de test au format <i><Font Color=#ff0000 > HTML. </Font></i></b></center>"
strHtml = strHtml & "</br>Veuillez prendre connaissance de la piece jointe."
strHtml = strHtml & "</BODY></HEAD></HTML>"
DerLig = Range("A" & Rows.Count).End(xlUp).Row
For n = 1 To DerLig
n = n + 1
destinataire = Cells(n, 3).Value
attachement = Cells(n, 8).Value
Set oCdo = CreateObject("cdo.Message")
'Set oConf = CreateObject("cdo.configuration")
'Set Flds = oConf.Fields
With oCdo.configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com" 'adresse du serveur smtp
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 'tester 25, 465 ou 587
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True 'Utilise une connection SSL (True or False)
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 40
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 '0 : pas d'authentification, 1 : authentification basique
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "MY GMAIL" 'identifiant de messagerie
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "MY PASSWORD" 'mot de passe de messagerie
.Update
End With
With oCdo
.Subject = "Votre facture" ' objet du message
.From = "MY GMAIL" ' adresse de l'expéditeur
.To = destinataire ' adresse du destinataire
.BCC = "" ' en copie cachée pour conserver trace
.HtmlBody = strHtml ' corps du message HTML
'.AddAttachment (attachement) ' ajout de pièce jointe
.MDNrequested = True
.Send
End With
Set oCdo = Nothing
Next n
End Sub
It's due to the line : .MDNrequested = True
If it is set to false or missing, it works.
I have the same problem. Excel restarts after the first .send when setting MDN to "True". The e-mail is still sent and asks for send a "reception feedback".
BR