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 :)
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.
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
)
I am writing an application that sends emails to an admin when there is a problem with the data. The account it's sending through is a Network Solutions SMTP server.
The code works most of the time, but about 1 out of 10 sends fail with the error -2147220973 "The transport failed to connect to the server".
Any suggestions on how to handle this?
Set imsg = CreateObject("cdo.message")
Set iconf = CreateObject("cdo.configuration")
Set Flds = iconf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.OurCompany.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 2525
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "me#OurCompany.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Update
End With
With imsg
Set .Configuration = iconf
.To = "me#MyEmail.com" 'CMemail
.From = "resupport#OurCompanycom"
.Subject = ACT
.HTMLBody = "Notification for " & CTName & " of " & CTCname & " " & ACT & ". You must manually Notify them about new docs for " & pname & ". " _
& "<br>Tell " & CTName & " to '" & Nz(DLookup("Notify", "TBLINVOICESETTINGS"), "") & " " & PRName & "_" & pname & ".pdf'"
.Send
End With
Set imsg = Nothing
Set iconf = Nothing
Should the smtpserverport be 25, is it being blocked by firewall?
This piece of code executes correctly :
Sub SMail(pTO As String, pSB As String, pBO As String, pAT As String)
On Error GoTo ErrH: Dim mm As CDO.Message: Set mm = New CDO.Message
mm.Configuration.Fields(cdoSMTPUseSSL) = "True"
mm.Configuration.Fields(cdoSendUsingMethod) = 2
mm.Configuration.Fields(cdoSMTPAuthenticate) = 1
mm.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
mm.Configuration.Fields(cdoSendUserName) = "MyID"
mm.Configuration.Fields(cdoSendPassword) = "MyPW"
'mm.Configuration.Fields(cdoSMTPConnectionTimeout) = 20
'mm.Configuration.Fields(cdoSMTPServerPort) = 25
mm.Configuration.Fields.Update
mm.From = "MyID"
mm.To = pTO
mm.Subject = pSB
mm.TextBody = pBO
mm.AddAttachment (pAT)
mm.send
ErrH: If Err Then MsgBox (Err.Number & " : " & Err.Description)
Set mm = Nothing
End Sub
The code below was posted by HK1 in response to an answer on sending email without Outlook in VBA, dated 20 Jul 12.
The code works well, but I need to add a signature block at the end of the text (basically a jpg file in a local folder), but the best I have been able to come up with is to add the path (text) instead of the image itself to the email body.
Const cdoSendUsingPickup = 1
Const cdoSendUsingPort = 2
Const cdoAnonymous = 0
' Use basic (clear-text) authentication.
Const cdoBasic = 1
' Use NTLM authentication
Const cdoNTLM = 2 'NTLM
Public Sub SendEmail()
Dim imsg As Object
Dim iconf As Object
Dim flds As Object
Dim schema As String
Set imsg = CreateObject("CDO.Message")
Set iconf = CreateObject("CDO.Configuration")
Set flds = iconf.Fields
' send one copy with SMTP server (with autentication)
schema = "http://schemas.microsoft.com/cdo/configuration/"
flds.Item(schema & "sendusing") = cdoSendUsingPort
flds.Item(schema & "smtpserver") = "mail.myserver.com"
flds.Item(schema & "smtpserverport") = 25
flds.Item(schema & "smtpauthenticate") = cdoBasic
flds.Item(schema & "sendusername") = "email#email.com"
flds.Item(schema & "sendpassword") = "password"
flds.Item(schema & "smtpusessl") = False
flds.Update
With imsg
.To = "email#email.com"
.From = "email#email.com"
.Subject = "Test Send"
.HTMLBody = "Test"
'.Sender = "Sender"
'.Organization = "My Company"
'.ReplyTo = "address#mycompany.com"
Set .Configuration = iconf
.Send
End With
Set iconf = Nothing
Set imsg = Nothing
Set flds = Nothing
End Sub
I tried amending the code as follows, but this simply adds the file path to the body text:
With imsg
.To = vRecipients
.From = senderEmail
.CC = vCC
.Subject = vSubject
vBody = Replace(vBody, vbCrLf, "<br>")
vBody = "<FONT face=arial size=2>" & vBody
vBody = vBody & "<br>" & signFile
.HTMLBody = vBody
.Sender = senderName
.ReplyTo = senderEmail
.AddAttachment vAttachments
Set .Configuration = iconf
.Send
End With
Any suggestions?
dwo is correct. You need to use a File System Object or a File Object to read in the text contents of your signFile. Otherwise your code looks like it should work.
Here's a function you can use to read the contents of a file. The function simply assumes that you'll pass in the entire path and file name for a text file that your application has at least read rights to.
Public Function GetTextFileContents(sFilePath as String) As String
If Dir(sFilePath) <> "" Then
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFilePath).OpenAsTextStream(1, -2)
GetTextFileContents = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
End If
End Function