Folder Subdirectory "Table of contents" listing - powershell
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.
Related
Data back NULL in OPC UA client with VB.net
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 :)
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
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
)
How to use multiple variables directly with CDOSYS parameters in Classic ASP
I am writing email sending code in Classic ASP using CDOSYS, but what i found when i try to write variables concatenation with CDOSYS parameters its gives me error.
I could not write code in following way-
mail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") = "admin#" & website
it givees me following error while execution - CDO.Message.1 error '80040213'
while following code works fine as its having single variable-
http://schemas.microsoft.com/cdo/configuration/sendusername") = websiteemail
Note:- Reason to use in that way because my client having many sites and previously we used CDONTS and ASPEMAILS and it used to work fine.
Here is the function I created:
function email(s_from,s_reply_to,s_recipients,s_bcc,s_subject,s_msg,s_type,s_msg_error_add,s_remote_host)
if (s_msg_error_add<>"") then s_msg_error_add = "<hr>" & vbCrLf & s_msg_error_add
if (s_remote_host="default") then s_remote_host = application("s_mail_server")
if (s_remote_host="") then s_remote_host = "localhost"
s_remote_host=lcase(s_remote_host)
's_recipients looks like "Scott <scott#domain.net>; Sue <andy#domain.net>" etc
s_from = replace(s_from,","," ",1,-1,1)
s_from = replace(s_from," "," ",1,-1,1)
s_from = replace(s_from,"[","<",1,-1,1)
s_from = replace(s_from,"]",">",1,-1,1)
if (s_reply_to<>"") then
s_reply_to = replace(s_reply_to,","," ",1,-1,1)
s_reply_to = replace(s_reply_to," "," ",1,-1,1)
s_reply_to = replace(s_reply_to,"[","<",1,-1,1)
s_reply_to = replace(s_reply_to,"]",">",1,-1,1)
end if
s_recipients = replace(s_recipients,",",";",1,-1,1)
s_recipients = replace(s_recipients," "," ",1,-1,1)
s_recipients = replace(s_recipients,"[","<",1,-1,1)
s_recipients = replace(s_recipients,"]",">",1,-1,1)
if (s_bcc<>"") then
s_bcc = replace(s_bcc,","," ",1,-1,1)
s_bcc = replace(s_bcc," "," ",1,-1,1)
s_bcc = replace(s_bcc,"[","<",1,-1,1)
s_bcc = replace(s_bcc,"]",">",1,-1,1)
end if
err.clear
Dim MailerConfig
Dim Mailer
Dim strRet
dim sch
strRet = ""
sch = "http://schemas.microsoft.com/cdo/configuration/"
Set MailerConfig = CreateObject("CDO.Configuration")
Set Mailer = CreateObject("CDO.Message")
With MailerConfig.Fields
'.Item(sch & "sendusing") = 2 'send using port - if err then this is really "SendUsingMethod"
'.Item(sch & "sendusingmethod") = 2 'send using port - if err then this is really "SendUsingMethod"
.Item(sch & "smtpconnectiontimeout") = 900
'.Item(sch & "smtpauthenticate") = 1 'use basic (clear-text) authentication
.Item(sch & "smtpserver") = s_remote_host
'.Item(sch & "smtpserverport") = 25
'.Item(sch & "sendusername") = SMAUTHUSER
'.Item(sch & "sendpassword") = SMAUTHPASS
.Update
End With
Mailer.Configuration = MailerConfig
'Mailer.Fields(cdoImportance) = 1
'Mailer.Fields("urn:schemas:mailheader:X-MSMail-Priority") = 1
'Mailer.Fields("urn:schemas:mailheader:X-Mailer") = ""
'Mailer.Fields.Update
'-- Set the Mail Properties
'on error resume next
Mailer.From = s_from
Mailer.To = s_recipients
if (s_reply_to<>"" and s_reply_to<>"na") then Mailer.ReplyTo = s_reply_to
b_redirect=false
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 72, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
if (s_bcc<>"" AND s_bcc<>"na" AND s_bcc<>"n/a") then Mailer.BCC = s_bcc
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 79, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
Mailer.Subject = s_subject
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 86, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
if (s_type="html") then
Mailer.AutoGenerateTextBody = True
s_msg = replace(s_msg,vbCrLf,"<br>",1,-1,1)
else
Mailer.AutoGenerateTextBody = False
end if
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 103, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
Mailer.MimeFormatted = False
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 110, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
if (s_type = "text") then
Mailer.TextBody = fn_dirty(s_msg)
else
's_msg_html = replace(s_msg,vbCrLf,"<br>",1,-1,1)
s_msg_html = s_msg
Mailer.HTMLBody = fn_dirty(s_msg_html)
end if
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 123, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
'-- Fire off the email message
Mailer.Send
if (err.number<>0 and err.number<>13) then
Select Case err.Number
Case -2147220973
strRet = " Failure to Send Report Message - Server Not Found" & vbCrLf & " Error: " & err.Number & " - " & err.Description
Case -2147220975
strRet = " Failure to Send Report Message - Server Authentication Failed" & vbCrLf & " Error: " & err.Number & " - " & err.Description
Case Else
strRet = " Failure to Send Report Message - Error: " & err.Number & " - " & err.Description
End Select
msg = "<br>Error in i_fn_email_cdo.asp: " & strRet & "<br><br>"
msg = msg & "remote host = " & s_remote_host & "<br>"
s_from = replace(s_from,"<","[",1,-1,1)
s_from = replace(s_from,">","]",1,-1,1)
s_reply_to = replace(s_reply_to,"<","]",1,-1,1)
s_reply_to = replace(s_reply_to,">","[",1,-1,1)
s_recipients = replace(s_recipients,"<","[",1,-1,1)
s_recipients = replace(s_recipients,">","]",1,-1,1)
s_bcc = replace(s_bcc,"<","[",1,-1,1)
s_bcc = replace(s_bcc,">","]",1,-1,1)
msg = msg & "from = " & s_from & "<br>"
msg = msg & "to = " & s_recipients & "<br>"
msg = msg & "subject = " & s_subject & "<br>"
msg = msg & "recipients = " & s_recipients & "<br><br>"
if (s_type = "text") then
msg = msg & s_msg
else
msg = msg & s_msg_html
end if
msg = msg & "<br>"
msg = msg & s_msg_error_add
session("msg") = msg
Set Mailer = Nothing
set MailerConfig = nothing
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
Set Mailer = Nothing
set MailerConfig = nothing
email = true
end function
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