le wiki de Fabrice : VBScript

VBScript : Toujours utile...

FilenameToClibpoard.vbs

Pratique pour copier rapidement le chemin complet du fichier transmit à ce script

InputBox "Chemin d'accès du fichier :", "Filename To Clipboard",  WScript.Arguments(0)

GetMondayOfWeek

Petite routine pour retrouver la date du lundi de la semaine en cours.

Public Function GetMondayOfWeek() As String
'--------------------------------------------------------------------------------
' Retourne la date du lundi de la semaine en cours
'--------------------------------------------------------------------------------

Const CST_Monday = "lundi"

Dim iLoop As Integer
Dim sTemp As String

    If Format(Now, "dddd") = CST_Monday Then
        GetMondayOfWeek = Format(Now, "dd/mm/yyyy")
        Exit Function
    End If
   
    iLoop = -1
    Do Until sTemp = "lundi"
        sTemp = Format(DateAdd("d", iLoop, Now), "dddd")

        If sTemp = CST_Monday Then
            GetMondayOfWeek = Format(DateAdd("d", iLoop, Now), "dd/mm/yyyy")
            Exit Do
        Else
            iLoop = iLoop - 1
        End If

    Loop

End Function

TOLOWER

Petite routine pour changer la casse d'une chaine...

Public Function TOLOWER(pChaine As String)
'================================================================================
' Date  :   20080424
' But   :   Change la casse de la chaine pour un format Prénom
' Ex.   :   ? TOLOWER("Frédérik da-silvà") ==> Frédérik Da-Silvà
'================================================================================


Dim bNewWord    As Boolean
Dim sChar       As String
Dim iCount      As Integer
Dim sOut        As String

If Len(Trim(pChaine)) = 0 Then
    TOLOWER = pChaine
    Exit Function
End If


For iCount = 1 To Len(pChaine)
    sChar = Mid(pChaine, iCount, 1)
    
    If iCount = 1 Or bNewWord Then
        sChar = UCase(sChar)
        bNewWord = False

    'ElseIf Asc(LCase(sChar)) >= 97 And Asc(LCase(sChar)) <= 122 Then
    ElseIf InStr("| -_", sChar) > 0 Then
        bNewWord = True

    Else
        sChar = LCase(sChar)
        bNewWord = False
        
    End If
    
    sOut = sOut & sChar
    
Next

    TOLOWER = sOut

End Function

MS Word : Mise à jour des champs (y compris en-tête)

Sub UpdateFields()
'================================================================================
' Date  :   20080404
' But   :   MAJ des champs (y compris en-tête et pied de page)
'================================================================================

Dim lSelStart   As Long
Dim lSelEnd     As Long

    ' Sauvegarde la position de la sélection
    lSelStart = Selection.Start
    lSelEnd = Selection.End

    'Sélectionne tout le document
    Selection.WholeStory
    
    ' MAJ de tous les champs
    Selection.Fields.Update
    
    ' Active l'entête
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    
    ' MAJ des champs de l'en-tête
    Selection.WholeStory
    Selection.Fields.Update
    
    
    ' Sélectionne le pied de page
    If Selection.HeaderFooter.IsHeader = True Then
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Else
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    End If
    
    ' MAJ des champs du pied de page
    Selection.WholeStory
    Selection.Fields.Update
    
    ' Sélectionne le document principal
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
    ' Restaure la position de la sélection
    Selection.Start = lSelStart
    Selection.End = lSelEnd

End Sub

MS Word : Redimensionner l'image sélectionné

Très pratique pour redimenssionner en 2 clics l'image sélectionnée dans le document Word.

Sub SizePictureToPercent()
'
' 1. Redimensionne l'image sélectionnée au pourcentage spécifié
' Centre l'image
' Encadre l'image

Dim iPercent    As Double

    ' Récupération du pourcentage de la taille souhaitée
    iPercent = InputBox("% de taille de l'image ?", "Réduire la taille d'une image", 80)
    If Not IsNumeric(iPercent) Then
        MsgBox "Pourcentage incorrect !", vbExclamation
        Exit Sub
    End If
    
    iPercent = iPercent / 100

    ' RAZ des propriétés de l'image
    Selection.InlineShapes(1).Reset
    
    ' Redimensionne l'image
    Selection.InlineShapes(1).LockAspectRatio = msoTrue
    Selection.InlineShapes(1).Height = Selection.InlineShapes(1).Height * iPercent
    Selection.InlineShapes(1).Width = Selection.InlineShapes(1).Width * iPercent
    
    ' Centre l'image
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    
    ' Encadre l'image
    With Selection.Borders(wdBorderTop)
        .LineStyle = Options.DefaultBorderLineStyle
        .LineWidth = Options.DefaultBorderLineWidth
        .Color = Options.DefaultBorderColor
    End With
    With Selection.Borders(wdBorderLeft)
        .LineStyle = Options.DefaultBorderLineStyle
        .LineWidth = Options.DefaultBorderLineWidth
        .Color = Options.DefaultBorderColor
    End With
    With Selection.Borders(wdBorderBottom)
        .LineStyle = Options.DefaultBorderLineStyle
        .LineWidth = Options.DefaultBorderLineWidth
        .Color = Options.DefaultBorderColor
    End With
    With Selection.Borders(wdBorderRight)
        .LineStyle = Options.DefaultBorderLineStyle
        .LineWidth = Options.DefaultBorderLineWidth
        .Color = Options.DefaultBorderColor
    End With
End Sub

Windows : Création d'un lecteur réseau

Petit script pour créer des lecteur réseau

Option Explicit

Dim strUser, wshShell

On Error Resume Next
Set wshShell = CreateObject("WScript.Shell")
strUser = wshShell.ExpandEnvironmentStrings("%USERNAME%")
If Err.Number <> 0 Then _
	WScript.Echo "Impossible de récupérer la variable d'environnement %USERNAME%, erreur(" & Err.Number & ")"
Err.Clear


'Connexion du lecteur P 'personnel'
CleanMap "P:"
MontageMap "P:", "\\srvdata\users$\" & strUser & "", True, "", ""
If Err.Number <> 0 AND Err.Number <> -2147024811 Then _
	WScript.Echo "Impossible de connecter le lecteur P, erreur(" & Err.Number & ")" & _
	vbCrLf & "	-> " & Err.Description & vbCrLf & "Veuillez contacter l'administrateur."
Err.Clear


Function MontageMap(nommap, path, persist, login, password)
'------------------------------------------------------------------------
' But : Monte un share distant en local
'------------------------------------------------------------------------

  Dim fso, Network

  On Error Resume Next
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set Network = CreateObject("WScript.Network")
  
  If login <> "" Then 
    Network.MapNetworkDrive nommap, path, persist,login,password
  Else
    Network.MapNetworkDrive nommap, path, persist
  End If

  if Err.Number <> 0 then
        MontageMap = false
  else
        MontageMap = True
  end If

End Function
 

Function CleanMap(nommap)
'------------------------------------------------------------------------
' But : Démonte un share distant en local
'------------------------------------------------------------------------

  Dim Network

  On Error Resume Next
  Set objNet = CreateObject("WScript.Network")
  objNet.RemoveNetworkDrive nommap,True,true

  If Err.Number <> 0 then
        CleanMap = false
  Else
        CleanMap = True
  End If

  On Error GoTo 0

End Function

IsVideOuNull

Afin de savoir en VB6 si une valeur est Vide ou Nulle

Function IsVideOuNull(cvalue) As Boolean
    On Error GoTo Fin
    
    IsVideOuNull = False
    
    If IsObject(cvalue) Then
        If (cvalue Is Nothing) Then
            IsVideOuNull = True
        ElseIf IsNull(cvalue) Then
            IsVideOuNull = True
        End If
    ElseIf IsNull(cvalue) Then
        IsVideOuNull = True
    ElseIf cvalue = "" Then
        IsVideOuNull = True
    End If
    
    Exit Function

Fin:
    IsVideOuNull = True
    
End Function

Function VideOuNull(cvalue, substitvalue)
    If IsVideOuNull(cvalue) Then
        VideOuNull = substitvalue
    Else
        VideOuNull = cvalue
    End If
End Function

! VBScript : Toujours utile...

!! FilenameToClibpoard.vbs
Pratique pour copier rapidement le chemin complet du fichier transmit à ce script
 InputBox "Chemin d'accès du fichier :", "Filename To Clipboard",  WScript.Arguments(0)

!! GetMondayOfWeek
Petite routine pour retrouver la date du lundi de la semaine en cours.

Public Function GetMondayOfWeek() As String
 '--------------------------------------------------------------------------------
 ' Retourne la date du lundi de la semaine en cours
 '--------------------------------------------------------------------------------
 
 Const CST_Monday = "lundi"
 
 Dim iLoop As Integer
 Dim sTemp As String
 
     If Format(Now, "dddd") = CST_Monday Then
         GetMondayOfWeek = Format(Now, "dd/mm/yyyy")
         Exit Function
     End If
    
     iLoop = -1
     Do Until sTemp = "lundi"
         sTemp = Format(DateAdd("d", iLoop, Now), "dddd")
 
         If sTemp = CST_Monday Then
             GetMondayOfWeek = Format(DateAdd("d", iLoop, Now), "dd/mm/yyyy")
             Exit Do
         Else
             iLoop = iLoop - 1
         End If
 
     Loop
 
 End Function
 
----

!! TOLOWER
Petite routine pour changer la casse d'une chaine...

Public Function TOLOWER(pChaine As String)
 '================================================================================
 ' Date  :   20080424
 ' But   :   Change la casse de la chaine pour un format Prénom
 ' Ex.   :   ? TOLOWER("Frédérik da-silvà") ==> Frédérik Da-Silvà
 '================================================================================
 
 
 Dim bNewWord    As Boolean
 Dim sChar       As String
 Dim iCount      As Integer
 Dim sOut        As String
 
 If Len(Trim(pChaine)) = 0 Then
     TOLOWER = pChaine
     Exit Function
 End If
 
 
 For iCount = 1 To Len(pChaine)
     sChar = Mid(pChaine, iCount, 1)
     
     If iCount = 1 Or bNewWord Then
         sChar = UCase(sChar)
         bNewWord = False
 
     'ElseIf Asc(LCase(sChar)) >= 97 And Asc(LCase(sChar)) <= 122 Then
     ElseIf InStr("| -_", sChar) > 0 Then
         bNewWord = True
 
     Else
         sChar = LCase(sChar)
         bNewWord = False
         
     End If
     
     sOut = sOut & sChar
     
 Next
 
     TOLOWER = sOut
 
 End Function
 
----

!! MS Word : Mise à jour des champs (y compris en-tête)

Sub UpdateFields()
 '================================================================================
 ' Date  :   20080404
 ' But   :   MAJ des champs (y compris en-tête et pied de page)
 '================================================================================
 
 Dim lSelStart   As Long
 Dim lSelEnd     As Long
 
     ' Sauvegarde la position de la sélection
     lSelStart = Selection.Start
     lSelEnd = Selection.End
 
     'Sélectionne tout le document
     Selection.WholeStory
     
     ' MAJ de tous les champs
     Selection.Fields.Update
     
     ' Active l'entête
     If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
         ActiveWindow.Panes(2).Close
     End If
     If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
         ActivePane.View.Type = wdOutlineView Then
         ActiveWindow.ActivePane.View.Type = wdPrintView
     End If
     ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
     
     ' MAJ des champs de l'en-tête
     Selection.WholeStory
     Selection.Fields.Update
     
     
     ' Sélectionne le pied de page
     If Selection.HeaderFooter.IsHeader = True Then
         ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
     Else
         ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
     End If
     
     ' MAJ des champs du pied de page
     Selection.WholeStory
     Selection.Fields.Update
     
     ' Sélectionne le document principal
     ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
     
     ' Restaure la position de la sélection
     Selection.Start = lSelStart
     Selection.End = lSelEnd
 
 End Sub
 
----

!! MS Word : Redimensionner l'image sélectionné

Très pratique pour redimenssionner en 2 clics l'image sélectionnée dans le document Word.

Sub SizePictureToPercent()
 '
 ' 1. Redimensionne l'image sélectionnée au pourcentage spécifié
 ' Centre l'image
 ' Encadre l'image
 
 Dim iPercent    As Double
 
     ' Récupération du pourcentage de la taille souhaitée
     iPercent = InputBox("% de taille de l'image ?", "Réduire la taille d'une image", 80)
     If Not IsNumeric(iPercent) Then
         MsgBox "Pourcentage incorrect !", vbExclamation
         Exit Sub
     End If
     
     iPercent = iPercent / 100
 
     ' RAZ des propriétés de l'image
     Selection.InlineShapes(1).Reset
     
     ' Redimensionne l'image
     Selection.InlineShapes(1).LockAspectRatio = msoTrue
     Selection.InlineShapes(1).Height = Selection.InlineShapes(1).Height * iPercent
     Selection.InlineShapes(1).Width = Selection.InlineShapes(1).Width * iPercent
     
     ' Centre l'image
     Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
     
     ' Encadre l'image
     With Selection.Borders(wdBorderTop)
         .LineStyle = Options.DefaultBorderLineStyle
         .LineWidth = Options.DefaultBorderLineWidth
         .Color = Options.DefaultBorderColor
     End With
     With Selection.Borders(wdBorderLeft)
         .LineStyle = Options.DefaultBorderLineStyle
         .LineWidth = Options.DefaultBorderLineWidth
         .Color = Options.DefaultBorderColor
     End With
     With Selection.Borders(wdBorderBottom)
         .LineStyle = Options.DefaultBorderLineStyle
         .LineWidth = Options.DefaultBorderLineWidth
         .Color = Options.DefaultBorderColor
     End With
     With Selection.Borders(wdBorderRight)
         .LineStyle = Options.DefaultBorderLineStyle
         .LineWidth = Options.DefaultBorderLineWidth
         .Color = Options.DefaultBorderColor
     End With
 End Sub

----

!! Windows : Création d'un lecteur réseau

Petit script pour créer des lecteur réseau

Option Explicit
 
 Dim strUser, wshShell
 
 On Error Resume Next
 Set wshShell = CreateObject("WScript.Shell")
 strUser = wshShell.ExpandEnvironmentStrings("%USERNAME%")
 If Err.Number <> 0 Then _
 	WScript.Echo "Impossible de récupérer la variable d'environnement %USERNAME%, erreur(" & Err.Number & ")"
 Err.Clear
 
 
 'Connexion du lecteur P 'personnel'
 CleanMap "P:"
 MontageMap "P:", "\\srvdata\users$\" & strUser & "", True, "", ""
 If Err.Number <> 0 AND Err.Number <> -2147024811 Then _
 	WScript.Echo "Impossible de connecter le lecteur P, erreur(" & Err.Number & ")" & _
 	vbCrLf & "	-> " & Err.Description & vbCrLf & "Veuillez contacter l'administrateur."
 Err.Clear
 
 
 Function MontageMap(nommap, path, persist, login, password)
 '------------------------------------------------------------------------
 ' But : Monte un share distant en local
 '------------------------------------------------------------------------
 
   Dim fso, Network
 
   On Error Resume Next
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set Network = CreateObject("WScript.Network")
   
   If login <> "" Then 
     Network.MapNetworkDrive nommap, path, persist,login,password
   Else
     Network.MapNetworkDrive nommap, path, persist
   End If
 
   if Err.Number <> 0 then
         MontageMap = false
   else
         MontageMap = True
   end If
 
 End Function
  
 
 Function CleanMap(nommap)
 '------------------------------------------------------------------------
 ' But : Démonte un share distant en local
 '------------------------------------------------------------------------
 
   Dim Network
 
   On Error Resume Next
   Set objNet = CreateObject("WScript.Network")
   objNet.RemoveNetworkDrive nommap,True,true
 
   If Err.Number <> 0 then
         CleanMap = false
   Else
         CleanMap = True
   End If
 
   On Error GoTo 0
 
 End Function
 
----

!! IsVideOuNull

Afin de savoir en VB6 si une valeur est Vide ou Nulle

Function IsVideOuNull(cvalue) As Boolean
     On Error GoTo Fin
     
     IsVideOuNull = False
     
     If IsObject(cvalue) Then
         If (cvalue Is Nothing) Then
             IsVideOuNull = True
         ElseIf IsNull(cvalue) Then
             IsVideOuNull = True
         End If
     ElseIf IsNull(cvalue) Then
         IsVideOuNull = True
     ElseIf cvalue = "" Then
         IsVideOuNull = True
     End If
     
     Exit Function
 
 Fin:
     IsVideOuNull = True
     
 End Function

Function VideOuNull(cvalue, substitvalue)
     If IsVideOuNull(cvalue) Then
         VideOuNull = substitvalue
     Else
         VideOuNull = cvalue
     End If
 End Function

Règles de formatage

_texte_: Faire une emphase (italique)
__texte__: Faire une emphase forte (gras)
@@texte@@: Faire un petit code
''texte|langue|source'': Faire une petite citation
>texte: Faire un paragraphe de citation
[texte|URI|langue|titre]: Faire un lien vers une page, les paramètres sont optionnels
((image|texte alternatif|alignement)): Ajouter une image, alignement peut valoir G(auche), D(roite) ou C(entre)
texte: Tout texte écrit simplement sera transformé en paragraphes.
!titre1, !!titre2, !!!titre3, etc.: Créer un titre d'un niveau égal au nombre de !
-texte ou *texte: Faire une liste d'éléments non numérotés
#texte: Faire une liste d'éléments numérotés
;titre:définition: Faire une définition/liste de définitions
??acronyme|titre??: Faire un acronyme
[ESPACE]texte ou {{{texte}}}: Le texte sera préformaté, utile pour écrire des bouts de code
==== ou ---- (au moins 4): Une ligne de séparation horizontale
\: Si vous ne voulez pas que la syntaxe wiki s'applique, faites précéder les caractères spéciaux par des anti-slashs.

Édition : VBScript