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