xGUICOM : composant COM (GUI) portable pour langage Active Scripting (VBScript/JScript)


précédentsommaire

8. Le script VBS

 

Les composants WSC ne supportent pas les caractères accentués lorsqu'ils ne sont pas sauvegardés en Unicode. Les commentaires sont donc volontairement dépourvus de toute accentuation.

 
Sélectionnez
<?xml version="1.0"?>
<component>
<?component error="true" debug="false"?>
<registration
  description="xGuiCom"
  progid="xGuiCom.WSC"
  version="1.00"
  classid="{e3ba4a33-2e7e-4539-badb-0a141ad397ff}"
>
</registration>
<comment>
  composant GUI ecrit en VBScript par omen999 - http://omen999.developpez.com/
  la boite de dialogue est creee avec l'api win32 et la bibliotheque dynwrapx.dll
  si cette dll n'a pas ete enregistree dans la bdr, elle sera creee automatiquement
  dans le meme repertoire que le composant avec l'executable wscript.exe.
  ce composant n'est pas ecrit en Unicode, il ne supporte donc aucun caractere accentue
</comment>
<public>
  <method name="CreateForm">
    <parameter name="sCaption"/>
    <parameter name="lLeft"/>
    <parameter name="lTop"/>
    <parameter name="lWidth"/>
    <parameter name="lHeight"/>
  </method>
  <method name="AddControl">
    <parameter name="iID"/>
    <parameter name="sClass"/>
    <parameter name="lLeft"/>
    <parameter name="lTop"/>
    <parameter name="lWidth"/>
    <parameter name="lHeight"/>
    <parameter name="sData"/>
    <parameter name="iStyle"/>
  </method>
  <method name="LoadLayoutFromRes">
    <parameter name="sData"/>
  </method>
  <method name="Show">
    <parameter name="iIDD"/>
    <parameter name="bOnTaskBar"/>
  </method>
  <method name="GetValueFromID">
    <parameter name="iID"/>
    <parameter name="hWndDlg"/>
  </method>
  <method name="SetValueFromID">
    <parameter name="iID"/>
    <parameter name="hWndDlg"/>
    <parameter name="vData"/>
  </method>
  <method name="AddItem">
    <parameter name="iID"/>
    <parameter name="hWndDlg"/>
    <parameter name="sData"/>
    <parameter name="iIndex"/>
  </method>
  <method name="RemoveItem">
    <parameter name="iID"/>
    <parameter name="hWndDlg"/>
    <parameter name="iIndex"/>
  </method>
  <method name="BinToB64">
    <parameter name="sFileName"/>
  </method>
  <event name="Launch"/>
  <event name="Create">
    <parameter name="iIDD"/>
    <parameter name="hWndDlg"/>
  </event>
  <event name="Close">
    <parameter name="iIDD"/>
    <parameter name="hWndDlg"/>
    <parameter name="iID"/>
  </event>
  <event name="Click">
    <parameter name="iIDD"/>
    <parameter name="hWndDlg"/>
    <parameter name="iID"/>
  </event>
  <event name="Change">
    <parameter name="iIDD"/>
    <parameter name="hWndDlg"/>
    <parameter name="iID"/>
  </event>
  <event name="Open">
    <parameter name="iIDD"/>
    <parameter name="hWndDlg"/>
    <parameter name="iID"/>
    <parameter name="sFileName"/>
  </event>
  <event name="Save">
    <parameter name="iIDD"/>
    <parameter name="hWndDlg"/>
    <parameter name="iID"/>
    <parameter name="sFileName"/>
  </event>
</public>
<script language="VBScript">
<![CDATA[
Option Explicit
 
Const _
WS_CHILD = &H40000000, _
WS_VISIBLE = &H10000000, _
WS_TABSTOP = &H10000, _
WS_GROUP = &H20000, _
BM_SETCHECK = &HF1, _
HKM_SETHOTKEY = &H401, _
GWL_USERDATA = (-21), _
SS_BITMAP = &HE, _
STM_SETIMAGE = &H172, _
LR_LOADFROMFILE = &H10, _
IMAGE_BITMAP = 0, _
IPM_SETADDRESS = &H465
 
Dim bInit              ' flag initialisation du composant
Dim oWrap              ' objet dynamicwrapperx
Dim oStream            ' objet stream
Dim oFso               ' objet filesystem
Dim hIns               ' handle de l'instance
Dim hWsh               ' handle de la fenetre principale WScript (gestion taskbar)
Dim pAdr               ' ptr proxy fonction callback DialogProc
Dim pIDisp             ' ptr interface fonction callback DialogProc 
Dim iC                 ' var generale compteur
Dim DLGTEMPLATEEX      ' tableau des structures de donnees binaires du dialogbox
                       ' format : <taille buffer:LONG><DLGTEMPLATE><DLGITEMTEMPLATE_1>..<DLGITEMTEMPLATE_n>
DLGTEMPLATEEX = Array()' pour gerer ubound sans erreur
Dim aDataDlg()	       ' tableau des buffers de donnees
                       ' ces donnes servent a initialiser les ctrls combobox, hotkey, ipcontrol et filedlgbox
                       ' format : <taille buffer:LONG><IDD dlgbox:WORD><ID ctrl_1:WORD><data unicode>...<ID ctrl_n:WORD>...
Dim OPENFILENAME       ' structure filedlgbox  
Dim sStrFile           ' buffer filedlgbox
Dim sStrFileTitle      ' buffer filedlgbox
 
Function Initialize()
' appel obligatoire avant toute autre fonction. Assure par CreateForm ou LoadLayoutFromRes
' extraction eventuelle de wscript.exe, dynwrapx.dll et instanciation des objets et variables
' temps de creation sur HD < 3 secs
' l'ecriture se fait en priorite avec l'objet ado stream et seulement a defaut
' par l'objet filesystem qui n'est pas concu pour ecrire des fichiers binaires
Const _
GWL_HINSTANCE = -6, _
adTypeBinary = 1, _
adTypeText = 2
Dim oXml  ' objet xmldom
Dim oElm  ' objet xmlelement 
  'test existence objet dynamicwrapperx
  On Error Resume Next
  For iC = 0 To 0 ' puzzling isn't it ;) permet de sortir de la boucle a volonte - comme un goto...
    Set oWrap = CreateObject("DynamicWrapperX")
    Set oStream = CreateObject("ADODB.Stream")
    If oStream Is Nothing Then
      'pas bon, on teste ensuite le filesystem
      Set oFso=CreateObject("Scripting.FileSystemObject")
      If oFso Is Nothing Then
        'cas desespere, on laisse tomber 
        MsgBox "Le composant DynamicWrapperX indispensable au bon fonctionnement de xGuiCOM est absent." & Chr(13) & _
               "Veuillez proc" & Chr(233) & "der " & Chr(224) & " son enregistrement avant d'utiliser xGuiCOM.", _
               vbCritical,"Erreur xGuiCOM v1.0"
        Exit Function
      Else
        If IsObject(oWrap) Then Exit For  ' sortie de boucle for..next oWrap et oFso sont dispo
        'l'objet fso existe, on extrait apres decodage la dll et wscript pour les enregistrer comme fichiers
        'sauf s'ils existent deja...
        If Not oFso.FileExists("dynwrapx.dll") Then 
          Set oStream = oFso.CreateTextFile("dynwrapx.dll")
          B64ToBin imgDynWrapX,oStream,0
          oStream.Close
        End If
        If Not oFso.FileExists("wscript.exe") Then 
          Set oStream = oFso.CreateTextFile("wscript.exe",True)
          B64ToBin imgWScript,oStream,0
        End If
      End If
    Else
      If IsObject(oWrap) Then Exit For ' sortie de boucle for..next oWrap et oStream sont dispo
      ' l'objet adostream existe, on extrait apres decodage la dll et wscript pour les enregistrer comme fichiers
      ' pour eviter de faire un SetEOS on commence par le + petit
      ' mais d'abord a tout hasard test objet ms.xmldom
      Set oXml = CreateObject("Microsoft.XMLDOM")
      If oXml Is Nothing Then
        oStream.Type = adTypeText
        oStream.CharSet = "Windows-1252"
      Else ' nickel la conversion base64 sera 20 fois + rapide
        oStream.Type = adTypeBinary
        Set oElm = oXml.createElement("tmp")
        oElm.DataType = "bin.base64"
        bXml = True
      End If
      oStream.Open
      ' test existence de la dll
      oStream.LoadFromFile "dynwrapx.dll"
      If oStream.Size = 0 Then
        If oXml Is Nothing Then
          B64ToBin imgDynWrapX,oStream,1
        Else
          oElm.Text = imgDynWrapX
          oStream.Write oElm.NodeTypedValue
        End If
        oStream.SaveToFile "dynwrapx.dll",2
      End If
      ' au tour de wscript.exe 
      oStream.Position = 0
      oStream.LoadFromFile "wscript.exe"
      If oStream.Size < 100000 Then  ' wscript fait au moins 155ko...
        If oXml Is Nothing Then
          B64ToBin imgWScript,oStream,1
        Else
          oElm.Text = imgWScript
          oStream.Write oElm.NodeTypedValue
        End If
        oStream.SaveToFile "wscript.exe",2
      End If	
    End If
    oStream.Close
    fireEvent "Launch"   ' relance du script appelant qui doit contenir l'event Launch
    Initialize = False
    Exit Function
  Next
  On Error GoTo 0 ' reactive la gestion des erreurs
  ' definition des fonctions API
  With oWrap
    .Register "user32","DialogBoxIndirectParamW","i=hphpp","r=l"
    .Register "user32","EndDialog","i=hl","r=l"
    .Register "user32","GetNextDlgTabItem","i=hhl","r=h"
    .Register "user32","GetDlgItem","i=hl","r=h"
    .Register "user32","GetClassNameA","i=hSl","r=l"
    .Register "user32","GetWindowTextA","i=hSl","r=l"
    .Register "user32","SetWindowTextA","i=hS","r=l"
    .Register "user32","FindWindowA", "i=SS","r=l"
    .Register "user32","GetWindowLongA","i=ll","r=l"
    .Register "user32","SendMessageW","i=hulW","r=l" ' gestion ptr chaine
    .Register "user32","SendMessage","i=hupp","r=l"  ' gestion valeurs unsigned
    .Register "user32","SendMessageA","i=hupl","r=l" ' gestion valeurs signed
    .Register "user32","SetWindowLongW","i=hlp","r=l"
    .Register "user32","GetWindowLongW","i=hl","r=l"
    .Register "user32","LoadImageW","i=hwullu","r=h"
    .Register "comdlg32","GetOpenFileNameW","i=p","r=l"
    .Register "comdlg32","GetSaveFileNameW","i=p","r=l"
    ' definition des params DialogBoxIndirectParam
    hWsh = .FindWindowA("WSH-Timer","")              ' recupere le handle de l'instance 
    hIns = .GetWindowLongA(hWsh,GWL_HINSTANCE)
    Set pIDisp = GetRef("DialogProc")                ' interface de la fonction callback appelee par DialogBoxIndirectParam
    pAdr = .RegisterCallback(pIDisp,"i=huul","r=l")  ' pointeur vers le code proxy qui appellera l'interface
  End With
  Initialize = True
End Function
 
Sub B64ToBin(ByRef sB64, ByRef Strm, ByVal iType)
' extension pour xGuiCom : decode egalement dans un buffer chaine
' pas de controle de conformation de la chaine d'entree
' sB64 : chaine d'entree en base64
' Strm : objet textstream ado, filesystem ou buffer chaine qui recevra les donnees binaires
' si buffer chaine, reserve un header long pour stocker la taille des donnees
' iType : 0 : filesystem ; 1 : ado ; 2 : chaine 
Const cB64Charset = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim iPointer   ' index du groupe traite
Dim iGSize     ' taille du groupe decode en binaire (gestion du caractere terminal '=')
Dim iOffset    ' index dans le groupe
Dim cChar      ' caractere courant
Dim cBin       ' valeur binaire du caractere
Dim iGBuffer   ' buffer numerique du groupe
Dim hGBuffer   ' buffer hexa du groupe
Dim cGBuffer   ' buffer binaire du groupe
Dim iPVar      ' ptr courant si Strm est une chaine
  'on commence par traiter la chaine d'entree par groupes de 4 octets
  'chaque groupe de 4 caracteres encode pour 3 octets binaires
  iGSize = 3
  iPVar = 3 ' -1 + 4 (taille header)
  For iPointer = 1 To Len(sB64) Step 4   
    iGBuffer = 0 'raz buffer
    For iOffset = 0 To 3 'boucle de traitement du groupe courant
      'lecture du caractere courant
      cChar = Mid(sB64,iPointer + iOffset,1)
      If cChar = "=" Then
      	'le complement n'entre pas dans le decodage
      	iGSize = iGSize - 1
      	cBin = 0
      Else
      	'le rang dans le charset donne la valeur binaire
      	cBin = InStr(1,cB64Charset,cChar,vbBinaryCompare) - 1
      End If
      'nouvelle valeur binaire ajoute apres decalage gauche de deux caracteres
      iGBuffer = 64 * iGBuffer + cBin
    Next
    'l'entier long est maintenant converti en une valeur chaine hexa de 6 caracteres max
    hGBuffer = Hex(iGBuffer)
    'formatage par ajout de zero a droite pour obtenir les 6 caracteres (2 x 3)
    hGBuffer = String(6 - Len(hGBuffer), "0") & hGBuffer
    'chaque groupe de 2 caracteres est converti en une valeur binaire
    cGBuffer = Chr(CByte("&h" & Mid(hGBuffer, 1, 2))) + _
               Chr(CByte("&h" & Mid(hGBuffer, 3, 2))) + _
               Chr(CByte("&h" & Mid(hGBuffer, 5, 2)))               
    Select Case iType
    Case 0 Strm.Write Left(cGBuffer,iGSize)      ' filesystem
    Case 1 Strm.WriteText Left(cGBuffer,iGSize)  ' ado
    Case 2 For iC = 1 to 3                       ' buffer chaine 
             oWrap.NumPut Asc(Mid(cGBuffer,iC,1)),Strm,iC + iPVar,"b" 
           Next
           iPVar = iPVar + 3
    End Select 
  Next
  If iType = 2 Then oWrap.NumPut iPVar,Strm  ' maj header avec taille des donnees
End Sub
 
Function MyASC(sChar)
  If sChar = "" Then MyASC = 0 Else MyASC = AscB(sChar)
End Function
 
Function BinToB64(sFile)
' convertit un fichier binaire en une chaine encodee base64 si erreur renvoie une chaine nulle
' sFileName : nom complet du fichier binaire
' utilise l'objet stream ado et a defaut filesystem defini par Initialize
Const cB64Charset = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", _
adTypeBinary = 1, _
adTypeText = 2
Dim sBinBuffer  ' work buffer
Dim oFile       ' objet fichier 
Dim aB64()      ' tableau de chaines B64 
Dim s24         ' groupe de 3 octets
Dim iPointer    ' ptr courant blocs
  BinToB64 = ""
  If Not bInit Then Exit Function 
  If IsObject(oStream) Then
    With oStream
      .Type = adTypeBinary
      .Open
      .LoadFromFile sFileName
      .Type = adTypeText 	    ' par defaut le charset est deja unicode
      If .Size = 0 Then Exit Function
      sBinBuffer = .ReadText
      .Close
    End With
  Else
    If IsObject(oFso) Then
      If oFso.FileExists(sFileName) Then
        ' fichier existe, lecture du binaire
        Set oFile = oFso.GetFile(sFileName)
        Set oStream = oFile.OpenAsTextStream(1)
        For iC = 0 to oFile.Size - 1
          oWrap.NumPut Asc(oStream.Read(1)),sBinBuffer,iC,"t"
        Next
     End If
    Else
      Exit Function 
    End If  
  End If
  ReDim aB64(Int(LenB(sBinBuffer)/3) + 1)
  For iPointer = 0 To LenB(sBinBuffer) - 1 Step 3
    ' lecture bloc 3 octets binaires
    s24 = Oct(&H10000 * AscB(MidB(sBinBuffer,iPointer + 1, 1)) + &H100 * _
              MyASC(MidB(sBinBuffer,iPointer + 2, 1)) + _
              MyASC(MidB(sBinBuffer,iPointer + 3, 1)))
    s24 = Right("00000000" & s24, 8)
    For iC = 0 To 3
      ' conversion 3 octets -> 4 caracteres ansi
      aB64(iPointer/3) = aB64(iPointer/3) & Mid(cB64CharSet,CLng("&o" & Mid(s24,iC* 2 + 1,2)) + 1,1)
    Next
  Next
  BinToB64 = Join(aB64,"")
  Select Case LenB(sBinBuffer) Mod 3
  Case 1
    BinToB64 = Left(BinToB64,Len(BinToB64) - 2) & "=="
  Case 2
    BinToB64 = Left(BinToB64,Len(BinToB64) - 1) & "="
  End Select
End Function
 
Function ParseHotKey(ByRef sHK)
' not quite good, but it's enough
' sHK : chaine decrivant la hotkey format sendkeys ex: {^+%X}
' renvoie la valeur hotkey numerique
Const _
HOTKEYF_ALT = &H4, _
HOTKEYF_CONTROL = &H2, _
HOTKEYF_SHIFT = &H1
Dim sFNum  ' hotkey fonction
  ParseHotKey = 0
  If Left(sHK,1) = "{" And Right(sHK,1) = "}" And Len(sHK) < 9 Then  ' max {^+?n}
    sHK = Mid(sHK,2,Len(sHK) - 2) ' trim {}
    ' weak part
    If InStr(sHK,"%") > 0 Then ParseHotKey = HOTKEYF_ALT
    If InStr(sHK,"^") > 0 Then ParseHotKey = ParseHotKey + HOTKEYF_CONTROL
    If InStr(sHK,"+") > 0 Then ParseHotKey = ParseHotKey + HOTKEYF_SHIFT
    If InStr(UCase(sHK),"F") > 0 And InStr(UCase(sHK),"F") < Len(sHK) Then ' touche fonction 
      sFNum = Mid(sHK,InStr(UCase(sHK),"F")+1) ' tout ce qui suit la lettre f
      On Error Resume Next  ' protection si mauvaise syntaxe pas glop...
      ParseHotKey = CInt(sFNum) + 111 + ParseHotKey * 256
      On Error GoTo 0
    Else
      ParseHotKey = Asc(UCase(Right(sHK,1))) + ParseHotKey * 256
    End If
  End If
End Function
 
Function ParseIPStr(ByRef sIP)
' sIP : valeur chaine au format xxx.xxx.xxx.xxx
' renvoie une valeur dword ou nulle si le format incorrect
Dim aVal ' tableau des groupes d'octets
  ParseIPStr = 0
  aVal = Split(sIP,".")
  If UBound(aVal) = 3 Then 
    On Error Resume Next ' capture l'erreur format, ParseIPStr renverra zero
    ' dword n'etant pas supporte nativement par vbs on le "fabrique"
    ParseIPStr = oWrap.Space(2,"")
    oWrap.NumPut CByte(aVal(1)) * 65536 + CByte(aVal(2)) * 256 + CByte(aVal(3)),ParseIPStr,0,"u"
    oWrap.NumPut CByte(aVal(0)),ParseIPStr,3,"b"
    ParseIPStr = oWrap.NumGet(ParseIPStr,0,"u") ' cast str -> dword
    On Error GoTo 0
  End If
End Function 
 
Sub BuildOpenFileName(ByRef pOPENFILENAME,ByRef aBoxData,hWnd)
' definit la structure pOPENFILENAME a partir des donnees aBoxData
Const OFN_OVERWRITEPROMPT = &H2
Dim aFilter(5) ' filtres extension
Dim sFilters   ' chaine filtres
Dim sExt       ' extension par defaut
Dim iUBound    ' nb items aboxdata
Dim hCtrl      ' handle ctrl iodata
Dim sValue     ' contenu ctrl iodata 
  With oWrap
    ' definition du filtre
    aFilter(0) = "Tous fichiers (*.*)"
    aFilter(1) = "*.*"
    aFilter(2) = "Fichiers script (*.wsf | *.vbs)"
    aFilter(3) = "*.wsf;*.vbs"
    aFilter(4) = "Fichiers texte (*.txt)"
    aFilter(5) = "*.txt"
    sFilters = Join(aFilter,vbNullChar) & vbNullChar & vbNullChar   
    sExt = "vbs"
    iUBound = UBound(aBoxData)
    If iUBound < 4 Then ReDim Preserve aBoxData(4)
    ' les nvx items doivent etre initialises sinon erreur
    For iC = iUBound +1 to 4
      aBoxData(iC) = ""
    Next
    .NumPut 76,pOPENFILENAME,0,"u"                    ' taille de la structure
    .NumPut hWnd,pOPENFILENAME,4,"h"                  ' le dialogue sera la fenetre parent   
                                                      ' hInstance est ignore +4
    .NumPut sFilters,pOPENFILENAME,12,"p"             ' filtres fichiers
                                                      ' customfilter et nMaxCustomFilter sont ignores +8  
    .NumPut 2,pOPENFILENAME,24,"u"                    ' nFilterIndex sur "*.wsf;*.vbs"
    On Error Resume Next
    hCtrl = .GetDlgItem(hWnd,CLng(aBoxData(1)))
    If (Err.Number = 0) And (hCtrl > 0) Then          ' iodata correspond a un ctrl du dlgbox
      sValue = GetValueFromID(CLng(aBoxData(1)),hWnd)
      If Right(sValue,1) <> "\" And Right(sValue,1) <> " " Then sStrFile = sValue & .Space(130 - Len(sValue),"")
      .NumPut sStrFile,pOPENFILENAME,28,"p"                           ' lpstrFile
      .NumPut 260,pOPENFILENAME,32,"u"                                ' nMaxFile 
      .NumPut sStrFileTitle,pOPENFILENAME,36,"p"                      ' lpStrFileTitle
      .NumPut 128,pOPENFILENAME,40,"u"                                ' nMaxFileTitle
      .NumPut Left(sValue,InStrRev(sValue,"\")),pOPENFILENAME,44,"p"  ' lpstrInitialDir
    Else ' iodata absent ou incorrect, utilise les 2 items suivants initialdir et file
      If (Len(aBoxData(3)) > 0) And (Right(aBoxData(3),1) <> "\") Then aBoxData(3) = aBoxData(3) & "\"
      If (Len(aBoxData(2)) > 0) And (aBoxData(2) <> " ") Then _
         sStrFile = aBoxData(3) & aBoxData(2) & .Space(130 - Len(aBoxData(3)) - Len(aBoxData(2)),"")
      .NumPut sStrFile,pOPENFILENAME,28,"p"                           ' lpstrFile
      .NumPut 260,pOPENFILENAME,32,"u"                                ' nMaxFile
      .NumPut sStrFileTitle,pOPENFILENAME,36,"p"                      ' lpStrFileTitle
      .NumPut 128,pOPENFILENAME,40,"u"                                ' nMaxFileTitle
      .NumPut aBoxData(3),pOPENFILENAME,44,"p"                        ' lpstrInitialDir
    End If
    .NumPut aBoxData(4),pOPENFILENAME,48,"p"           ' lpstrTitle
    .NumPut OFN_OVERWRITEPROMPT,pOPENFILENAME,52,"u"   ' Flags pour la liste complete voir MSDN Library 
                                                       ' nFileOffset et nFileExtension sont ignores +4
    .NumPut sExt,pOPENFILENAME,60,"p"                  ' lpstrDefExt par defaut .vbs
                                                       ' le reste de la structure n'est pas utile
    On Error GoTo 0
  End With
End Sub
 
Function DialogProc(hWndDlg,uMsg,wParam,lParam)
' callback appelee par DialogBoxIndirectParamA (voir fonction Show)
' permet la gestion des messages du dialogue et donc des evenements
Const _
WM_CLOSE = &H10, _
WM_COMMAND = &H111, _
WM_INITDIALOG = &H110, _
LB_ADDSTRING = &H180, _
CB_ADDSTRING = &H143, _
CB_SETCURSEL = &H14E, _
WM_USER = &H400, _
BST_CHECKED = &H1, _
GWL_STYLE = (-16), _
GWL_EXSTYLE = (-20), _
EN_CHANGE = &H300, _
BN_CLICKED = 0, _
LBN_SELCHANGE = 1
 
Dim iIDD         ' ID dlgbox
Dim iID	  	     ' ID ctrl courant
Dim hPWnd        ' handle ctrl precedent
Dim hNWnd        ' handle ctrl courant 
Dim iCC          ' variable compteur secondaire
Dim sClsName     ' nom classe controle
Dim sWinTxt      ' texte du controle
Dim aList        ' liste items listbox ou combobox
Dim pCur         ' ptr courant aDataDlg()
Dim pEoDD        ' ptr EndofData aDataDlg()
Dim aBoxData     ' tableau donnees filedlgbox
Dim OPENFILENAME ' structure filedlgbox  
  iIDD = oWrap.GetWindowLongW(hWndDlg,GWL_USERDATA) ' renvoie 0 si WM_INITDIALOG et l'ID du dlg pour les autres msgs
  Select Case uMsg
  Case WM_CLOSE
    fireEvent "Close",iIDD,hWndDlg,0  ' evenement close par convention l'ID egal a zero
    oWrap.EndDialog hWndDlg,0         ' fermeture menu systeme ID met fin au dialogue et renvoie 0
    DialogProc = True
  ' ******************************************************************* NOTIFICATIONS DES CTRLS
  Case WM_COMMAND
    'On Error Resume Next            ' pas d'erreur meme si l'evenement n'a pas ete defini dans le script client
    iID = wParam mod 65536 			 ' low word - contient l'ID du controle auteur du msg
    DialogProc = True	
    Select Case Fix(wParam/65536)   ' high word
    Case BN_CLICKED
      If (iID < 8 And iID > 0) Then ' seuls les boutons d'ID 1 a 7 ferment le dlg (reproduit comportement MsgBox)
        fireEvent "Close", iIDD, hWndDlg,iID ' evenement close 
        oWrap.EndDialog hWndDlg,iID
      Else
      If oWrap.GetWindowLongW(lParam,GWL_USERDATA) > 0 Then ' userdata existent : pseudo-ctrl filedlgbox
        ' format donnes : type|iodata|filename|initialdir|titre
        ' type : 0 OpenFileDlgBox ; 1 SaveFileDlgBox  > 1 reserve pour d'autres pseudo-ctrls - requis
        ' iodata : ID du ctrl contenant(open)/recevant(save) le nom fichier - optionnel alternatif
        ' filename : valeur chaine ou nom de variable ou ID du ctrl contenant le nom par defaut du fichier - optionnel alternatif
        ' initialdir : valeur chaine ou nom de variable ou ID du ctrl contenant le repertoire par defaut - optionnel
        ' titre : valeur chaine ou nom de variable ou ID du ctrl contenant le titre du dlg - optionnel
        aBoxData = Split(oWrap.StrGet(oWrap.GetWindowLongW(lParam,GWL_USERDATA)),"|")
        OPENFILENAME = oWrap.Space(38,"") ' OPENFILENAME_SIZE_VERSION_400 : 76
        sStrFile = oWrap.Space(130,"")    ' buffer nom fichier complet
        sStrFileTitle = oWrap.Space(64,"")' buffer nom du fichier seul sans chemin
        BuildOpenFileName oWrap.StrPtr(OPENFILENAME),aBoxData,hWndDlg             
        Select Case aBoxData(0)
        Case 0 
          If oWrap.GetOpenFileNameW(oWrap.StrPtr(OPENFILENAME)) <> 0 Then                
            fireEvent "Open",iIDD,hWndDlg,iID,sStrFile
          End If  
        Case 1
          If oWrap.GetSaveFileNameW(oWrap.StrPtr(OPENFILENAME)) <> 0 Then
            fireEvent "Save",iIDD,hWndDlg,iID,sStrFile
          End If  
        Case Else
          MsgBox "Contr" & Chr(244) & "le inconnu",vbCritical,"Erreur xGuiCOM v1.0"
        End Select
      Else 
        fireEvent "Click",iIDD,hWndDlg,iID  ' evenement click avec l'ID du ctrl auteur en parametre
      End If
    End If
    Case EN_CHANGE,LBN_SELCHANGE    ' or CBN_SELCHANGE
      fireEvent "Change",iIDD,hWndDlg,iID     ' evenement change avec l'ID du ctrl auteur en parametre
    Case Else
      DialogProc=False
    End Select
    ' ************************************************************** INITIALISATION  DU DLG	
    Case WM_INITDIALOG
	' la chaine buffer aDataDlg(iIDD) a ete passee en dwInitParam donc lParam pointe vers elle
    hPWnd=0
    With oWrap
      sClsName = .Space(16,"")
      sWinTxt =  .Space(4096,"")
      iIDD = .NumGet(lParam,4,"t")    ' ID du dialogue stocke dans aDataDlg(iIDD)
      ' init ctrls listbox, checkbox, radiobutton et image
      For iC = 1 to .NumGet(DLGTEMPLATEEX(iIDD),20,"t") ' to nb de controles + offset 4 (header)
        hNWnd = .GetNextDlgTabItem(hWndDlg,hPWnd,0)
        .GetClassNameA hNWnd,sClsName,32
        Select Case sClsName  
        Case "ListBox"
          .GetWindowTextA hNWnd,sWinTxt,8192
          aList = Split(sWinTxt,"|")
          For iCC = 0 to UBound(aList)
            .SendMessageW hNWnd,LB_ADDSTRING,0,aList(iCC)
          Next
        Case "Button"  ' checkbox, radiobutton
          ' par defaut exStyle = 4 donc si exStyle = 4 + 2  checkbox ou radiobutton coche
          If .GetWindowLongA(hNWnd,GWL_EXSTYLE) = 6 Then _
            .SendMessageA hNWnd,BM_SETCHECK,BST_CHECKED,0
        Case "Static" '  image
          .GetWindowTextA hNWnd,sWinTxt,8192			  			  
          .SendMessageA hNWnd,STM_SETIMAGE,IMAGE_BITMAP,.LoadImageW(0,sWinTxt,IMAGE_BITMAP,0,0,LR_LOADFROMFILE)
          .SetWindowLongW hNWnd,GWL_STYLE,SS_BITMAP + WS_CHILD + WS_VISIBLE + WS_GROUP ' supprime le tabstop inutile
        End Select
        hPWnd = hNWnd
      Next
      ' lecture du buffer aDataDlg, init combobox, hotkey, ipcontrol, dlgfilebox - a little more touchy
      ' iIDD sauvegarde en userdata attachee au dlg - utilise par les events pour identifier le dlg auteur
      .SetWindowLongW hWndDlg,GWL_USERDATA,iIDD 
      pEoDD = .NumGet(lParam) ' lecture header pour connaitre la taille utile du buffer
      If pEoDD > 6 Then ' des donnees controles existent a partir de l'offset 6
        pCur = lParam + 6 
        Do ' lecture aDataDlg(iUp)
          iID = .NumGet(pCur,0,"t")      ' ID du ctrl
          sWinTxt = .StrGet(pCur + 2)    ' chaine des items a placer dans le combo
          hNWnd = .GetDlgItem(hWndDlg,iID)
          .GetClassNameA hNWnd,sClsName,32
          Select Case sClsName
          Case "Button" ' pseudo-ctrl filedlgbox (OpenFileDlgBox/SaveFileDlgBox)
            aBoxData = Split(sWinTxt,"|")
            If (UBound(aBoxData) > 0) Then
              If IsNumeric(aBoxData(1)) Then
                .SetWindowTextA hNWnd,aBoxData(0) ' maj legende du bouton avec le 1er item 
                ' les donnees doivent etre dispos pour l'event click le pointeur est place en userdata
                .SetWindowLongW hNWnd,GWL_USERDATA,pCur + LenB(aBoxData(0)) + 4 ' skip caption|
              End If
            End If
          Case "ComboBox"
            aList = Split(sWinTxt,"|")
            For iCC = 0 to UBound(aList) ' alimentation de la combobox
              .SendMessageW hNWnd,CB_ADDSTRING,0,aList(iCC)
            Next
            .SendMessageA hNWnd,CB_SETCURSEL,0,0 ' 1er item selectionne
          Case "msctls_hotkey32"
            .SendMessageA hNWnd,HKM_SETHOTKEY,ParseHotKey(sWinTxt),0
          Case "SysIPAddress32"
            .SendMessage hNWnd,IPM_SETADDRESS,0,ParseIPStr(sWinTxt)
          End Select
          pCur = pCur + 4 + LenB(sWinTxt)     ' offset iID + zero terminal = 4
        Loop Until pCur >= lParam + pEoDD - 6  ' ne pas oublier de deduire le header et l'iIDD
      End If
      'On Error Resume Next             ' pas d'erreur meme si l'evenement n'a pas ete defini dans le script client
      fireEvent "Create",iIDD,hWndDlg  ' evenement create du script client avec l'ID et le handle du dlg
      DialogProc=True
    End With
  Case Else
    DialogProc=False
  End Select	
End Function
 
Function CreateForm(sCaption,lLeft,lTop,lWidth,lHeight)
' sCaption : titre du dialogue
' lLeft,lTop: coordonnees relatives de l'angle haut gauche de la feuille
' lWidth, lHeight: dimensions de la feuille
' renvoie l'ID du dlg cree entre 0..n sinon -1
Const _
WS_CAPTION = &HC00000, _
WS_SYSMENU = &H80000, _
DS_MODALFRAME = &H80, _
DS_SETFONT = &H40, _
sFont = "MS Shell Dlg 2"
Dim iUp    ' indice du dlg cree
Dim pEoDT  ' ptr EndofData buffer DLGTEMPLATEEX(iUp)
  If not bInit Then
    If not Initialize Then
      CreateForm = -1
      Exit Function
    End if
    bInit = True
  End If
  ' creation des structure et buffer
  iUp = UBound(DLGTEMPLATEEX) + 1 ' comme DLGTEMPLATEEX a ete cree avec array() ubound renvoie -1 si vide
  ReDim Preserve DLGTEMPLATEEX(iUp)
  ReDim Preserve aDataDlg(iUp)
  With oWrap
    ' le buffer data sera eventuellement alimente lorsque des controles seront ajoutes (fonction AddControl)
    aDataDlg(iUp) = .Space(4096,"")               ' buffer 8 Ko pour les donnees init des controles combobox, hotkey, ipcontrol et filedlgbox
    .NumPut iUp,aDataDlg(iUp),4,"t"               ' IDD du dlg
    .NumPut 6,aDataDlg(iUp)                       ' maj du header la taille utile du buffer = celle du header + l'IDD du dlg  donc 4 + 2
    DLGTEMPLATEEX(iUp) = .Space(4096,"") 		  ' buffer 8 Ko - peut etre aug/dim selon le nb de ctrls
    pEoDT = .NumPut(4,DLGTEMPLATEEX(iUp))         ' maj header taille utile = celle du header donc 4
    ' assemblage structure DLGTEMPLATEEX 
    pEoDT = .NumPut(4294901761,pEoDT,0,"u")       'EX global header &HFFFF0001
    ' pas d'HelpID ni d'exStyle, on passe direct au style (offset 8)
    pEoDT = .NumPut(WS_SYSMENU + WS_CAPTION + DS_MODALFRAME + DS_SETFONT,pEoDT,8,"u")
    pEoDT = .NumPut(0,pEoDT,0,"t")                ' nb de ctrls = 0, maj ulterieurement par AddControl
    pEoDT = .NumPut(lLeft,pEoDT,0,"n")
    pEoDT = .NumPut(lTop,pEoDT,0,"n")
    pEoDT = .NumPut(lWidth,pEoDT,0,"n")
    pEoDT = .NumPut(lHeight,pEoDT,0,"n")
    ' pas de menu et la classe par defaut #32770 est choisie, -> on passe direct au titre (offset 4)
    pEoDT = pEoDT + 4
    ' NumPut n'accepte que les valeurs numeriques, decoupage de sCaption en valeurs 16bits (caractere unicode)	
    For iC=1 to Len(sCaption)
      pEoDT = .NumPut(Asc(Mid(sCaption,iC,1)),pEoDT,0,"t")
    Next
    pEoDT = .NumPut(0,pEoDT,0,"t") ' zero terminal string unicode
    pEoDT = .NumPut(8,pEoDT,0,"t") ' pointsize defaut 8
    pEoDT = .NumPut(0,pEoDT,0,"t") ' FW_DONTCARE
    pEoDT = .NumPut(0,pEoDT,0,"b") ' italique
    pEoDT = .NumPut(1,pEoDT,0,"b") ' charset par defaut (celui decrit dans sFont)
    For iC=1 to Len(sFont)
      pEoDT = .NumPut(Asc(Mid(sFont,iC,1)),pEoDT,0,"t")
    Next
    pEoDT = .NumPut(0,pEoDT,0,"t") ' zero terminal string unicode
    .NumPut pEoDT - .StrPtr(DLGTEMPLATEEX(iUp)),DLGTEMPLATEEX(iUp) ' maj header taille des donnes utiles
  End With
  CreateForm = iUp
End Function
 
Sub BuildDataDlg(iID,ByRef aData, ByRef sData, pCur)
' maj le buffer aDataDlg avec les donnees initiales de certains ctrls
  If Len(sData) > 0 Then
    With oWrap
      pCur = .NumPut(iID,aData,pCur,"t")                 ' ID ctrl					
      For iC=1 to Len(sData)
        pCur = .NumPut(Asc(Mid(sData,iC,1)),pCur,0,"t")  ' data (item0|item1|..|itemn)
      Next
      pCur = .NumPut(0,pCur,0,"t")                       ' zero terminal
      .NumPut pCur - .StrPtr(aData),aData                ' maj header
    End With
  End If
End Sub
 
Function AddControl(iID,sClass,lLeft,lTop,lWidth,lHeight,sData,iStyle)
' ajoute un controle sur la feuille creee par la methode CreateForm
' iID: ID unique du controle
' sClass: nom de classe du ctrl 
' noms supportes : label, edit, edpsw, memo, commandbutton, listbox, combobox, checkbox, optionbutton,
'                  groupbox, image, scrollbar, hotkey, ipcontrol, progressbar et filedlgbox
' lLeft,lTop: coordonnees relatives de l'angle haut gauche du controle
' lWidth, lHeight: dimensions du controle
' sData: donnees initiales du controle a creer (facultatif)
' listbox et combobox : sData contient la liste des items avec le caractere | comme separateur
' iStyle: style propre du controle (facultatif)
' renvoie true si ok sinon false
Const _
WS_VSCROLL = &H200000, _
WS_HSCROLL = &H100000, _
WS_BORDER = &H800000, _
BS_PUSHBUTTON = &H0, _
BS_DEFPUSHBUTTON = &H1, _
BS_AUTOCHECKBOX = &H3, _
BS_GROUPBOX = &H7, _
BS_AUTORADIOBUTTON = &H9, _
BS_FLAT = &H8000, _
CBS_SIMPLE = &H1, _
CBS_DROPDOWN = &H2, _
CBS_DROPDOWNLIST = &H3, _
CBS_AUTOHSCROLL = &H40, _
ES_AUTOHSCROLL = &H80, _
ES_AUTOVSCROLL = &H40, _
ES_PASSWORD = &H20, _
ES_MULTILINE = &H4, _
ES_WANTRETURN = &H1000, _
ES_LOWERCASE = &H10, _
SS_ICON = &H3, _
LBS_NOTIFY = &H1, _
LBS_SORT = &H2, _
PBS_SMOOTH = &H1, _
SBS_HORZ = &H0, _
SBS_VERT = &H1, _
WS_CTRLSTD = &H50010000  ' WS_CHILD + WS_VISIBLE + WS_TABSTOP
Dim iUp     ' indice du dlg courant
Dim pEoDT   ' ptr EndofData buffer DLGTEMPLATEEX(iUp)
Dim pEoDD   ' ptr EndofData aDataDlg(iUp)
Dim aData   ' tableau donnees des pseudo-controles 
Dim iClass  ' system class
Dim bChk    ' flag checked pour radiobox et checkbox
  AddControl = False
  ' composant pas initialise par un appel a CreateForm ou LoadLayoutFromFile donc echec
  If Not bInit Then Exit Function 
  If iID < 1 Then 
    Err.Raise 10000,"Fonction AddControl","L'identifiant du contr" & Chr(244) & "le doit " & Chr(234) & _
                    "tre sup" & Chr(233) & "rieur ou " & Chr(233) & "gal " & Chr(224) & " un"
    Exit Function
  End If
  iUp = UBound(DLGTEMPLATEEX) ' derniere structure du tableau (dlg courant)
  ' offset end of data = taille utile du buffer stocke en header (LONG)
  pEoDD = oWrap.NumGet(aDataDlg(iUp)) ' lecture du header (valeur >=6)
  Select Case LCase(sClass)
  Case "commandbutton"
    iClass = 8454143 ' system class button (&h0080)
    If iStyle < 2 Then iStyle = iStyle + WS_CTRLSTD ' 0 = pushbutton, 1 = pushbutton defaut
  Case "optionbutton"
    iClass = 8454143 ' system class button (&h0080)
    If iStyle = 1 Then bChk = True
    If iStyle < 2 Then iStyle = BS_AUTORADIOBUTTON + WS_CTRLSTD
  Case "checkbox"
    iClass = 8454143 ' system class button (&h0080)
    If iStyle = 1 Then bChk = True
    If iStyle < 2 Then iStyle = BS_AUTOCHECKBOX + WS_CTRLSTD
  Case "frame"
    iClass = 8454143 ' system class button (&h0080)
    If iStyle = 0 Then iStyle = BS_GROUPBOX + WS_CTRLSTD + WS_GROUP
  Case "edit"
    iClass = 8519679 ' system class edit (&h0081)
    If iStyle = 0 Then iStyle = ES_AUTOHSCROLL + WS_BORDER + WS_CTRLSTD
  Case "edpswd"
    iClass = 8519679 ' system class edit (&h0081)
    If iStyle = 0 Then iStyle = ES_PASSWORD + ES_AUTOHSCROLL + WS_BORDER + WS_CTRLSTD
  Case "memo"
    iClass = 8519679 ' system class edit (&h0081)
    If iStyle = 0 Then iStyle = ES_MULTILINE + ES_WANTRETURN + WS_BORDER + ES_AUTOHSCROLL + ES_AUTOVSCROLL + WS_CTRLSTD
  Case "label"
    iClass = 8585215 ' system class static (&h0082)
    If iStyle = 0 Then iStyle = WS_CHILD + WS_VISIBLE + WS_GROUP
  Case "image"      
    iClass = 8585215 ' system class static (&h0082)
    If iStyle = 0 Then iStyle = SS_BITMAP + WS_CHILD + WS_VISIBLE + WS_GROUP + WS_TABSTOP
    ' sData contient soit un nom de constante du script client soit un nom de fichier - traite au stade de la dialogproc	
    ' le style WS_TABSTOP normalement inutile pour un ctrl static permettra de le recuperer sans utiliser aDataDlg
  Case "icon"        
    iClass = 8585215 ' system class static (&h0082)
    If iStyle = 0 Then iStyle = SS_ICON + WS_CHILD + WS_VISIBLE + WS_GROUP
  Case "listbox"
    iClass = 8650751 ' system class listbox (&h0083)
    If iStyle = 0 Then iStyle = LBS_NOTIFY + LBS_SORT + WS_VSCROLL + WS_BORDER + WS_CTRLSTD
  Case "scrollbar"
    iClass = 8716287 ' system class scrollbar (&h0084)
    If iStyle < 2 Then iStyle = WS_CHILD + WS_VISIBLE + iStyle ' 0 = horizontale, 1 = verticale
  Case "filedlgbox" ' traite comme un commandbutton mais aDataDlg est alimente avec les donnees sData
    iClass = 8454143 ' system class button (&h0080)
    If iStyle < 2 Then iStyle = iStyle + WS_CTRLSTD ' 1 : commandbutton defaut
    aData = Split(sData,"|")                        
    If (UBound(aData) > 1) And IsNumeric(aData(1)) Then ' test format donnees - au moins (caption|type)
      BuildDataDlg iID,aDataDlg(iUp),sData,pEoDD
    Else
      Err.Raise 10001,"Fonction AddControl","Erreur de syntaxe : le contr" & Chr(244) & "le filedlgbox n'est pas cr" & Chr(233) & Chr(233)
      Exit Function
    End If
  Case "combobox"    
    iClass = 8781823 ' system class combobox (&h0085)
    If iStyle = 0 Then iStyle = CBS_DROPDOWNLIST + CBS_AUTOHSCROLL + WS_VSCROLL + WS_CTRLSTD
    BuildDataDlg iID,aDataDlg(iUp),sData,pEoDD
  Case "hotkey"
    iClass = "msctls_hotkey32" ' non system class, iClass est une chaine et non une valeur ordinale
    If iStyle = 0 Then iStyle = WS_BORDER + WS_CTRLSTD
    ' idem controle combobox & ipcontrol
    BuildDataDlg iID,aDataDlg(iUp),sData,pEoDD
  Case "ipcontrol"
    iClass = "SysIPAddress32"
    If iStyle = 0 Then iStyle = WS_CTRLSTD
    'idem controle hotkey & combobox
    BuildDataDlg iID,aDataDlg(iUp),sData,pEoDD
  Case "progressbar"
    iClass = "msctls_progress32"
    If iStyle = 0 Then iStyle = WS_CHILD + WS_VISIBLE + PBS_SMOOTH	' PBS_SMOOTH donne un aspect plein a la barre
  Case Else
    Err.Raise 10002,"Fonction AddControl","La classe " & LCase(sClass) & " n'est pas une classe support" & Chr(233) & "e"
	Exit Function
  End Select
  ' ajout d'une structure DLGITEMTEMPLATEEX a la structure DLGTEMPLATEEX existante
  With oWrap
    pEoDT = oWrap.NumGet(DLGTEMPLATEEX(iUp)) ' lecture du header - offset fin donnees utiles
    pEoDT = pEoDT + pEoDT Mod 4              ' ALIGNEMENT DWORD
    If bChk Then  ' exStyle sert a initialiser les check et radiobox (skip helpID offset 4)
      pEoDT = .NumPut(2,.StrPtr(DLGTEMPLATEEX(iUp)) + pEoDT,4,"u")  ' checked
    Else
      pEoDT = .NumPut(0,.StrPtr(DLGTEMPLATEEX(iUp)) + pEoDT,4,"u")  ' unchecked
    End If
    pEoDT = .NumPut(iStyle,pEoDT,0,"u")
    pEoDT = .NumPut(lLeft,pEoDT,0,"n")
    pEoDT = .NumPut(lTop,pEoDT,0,"n")
    pEoDT = .NumPut(lWidth,pEoDT,0,"n")
    pEoDT = .NumPut(lHeight,pEoDT,0,"n")
    pEoDT = .NumPut(iID,pEoDT,0,"u")    ' ATTENTION control ID DWORD et non WORD
    If VarType(iClass) = 3 Then ' system class
      pEoDT = .NumPut(iClass,pEoDT,0,"u")  ' system class FFFF008x
    Else                                   ' nom de classe specifique (chaine)
      For iC=1 to Len(iClass)
        pEoDT = .NumPut(Asc(Mid(iClass,iC,1)),pEoDT,0,"t")
      Next
      pEoDT = .NumPut(0,pEoDT,0,"t") ' zero terminal
    End If
    If Len(sData) > 0 Then
      For iC=1 to Len(sData)
        pEoDT = .NumPut(Asc(Mid(sData,iC,1)),pEoDT,0,"t")
      Next
    End If
    pEoDT = .NumPut(0,pEoDT,0,"u") ' zero terminal + ext data  WORD + WORD = DWORD...	
    .NumPut .NumGet(DLGTEMPLATEEX(iUp),20,"t") + 1,DLGTEMPLATEEX(iUp),20,"t" ' maj du nb de ctrls dans le header DLGTEMPLATEEX
    .NumPut pEoDT - .StrPtr(DLGTEMPLATEEX(iUp)),DLGTEMPLATEEX(iUp)           ' maj header taille des donnes utiles
  End With
  AddControl = True
End Function
 
Sub ParseBinRes(ByRef sData)
' analyse et recupere les valeurs d'initialisation des controles combobox, button (filedlgbox), hotkey et ipcontrol
' a partir de la structure DLGTEMPLATEEX dispo sous la forme binaire brute
' ces valeurs alimenteront un buffer aDataDlg(iUp) qui sera lu lors de l'initialisation du dlg
' la DLGTEMPLATEEX est egalement mis a jour
' NOTE : ne gere que les dlg avec la classe system par defaut, style DS_SETFONT et sans menu
' sData : buffer aDataDlg(iUp)
Dim sBuf     ' buffer DLGTEMPLATEEX
Dim sCaption '  titre dlgbox
Dim sFont    ' font dlgbox
Dim pBase    ' adresse de base du buffer de travail puis des structures DLGITEMTEMPLATEEX
Dim iDTE     ' taille DLGTEMPLATEEX
Dim iOffset  ' offset courant
Dim cClass   ' system class (numerique)
Dim sClass   ' nom classe
Dim sInit    ' donnees inits du ctrl
Dim iID      ' ID ctrl
Dim pEoDD    ' offset EndofData aDataDlg(iUp)
Dim iUp
  iUp = UBound(aDataDlg)
  sBuf = sData
  pBase = oWrap.StrPtr(sBuf) + 4  ' skip header taille des donnees
  ' skip DLGTEMPLATEEX pour atteindre le 1er DLGITEMTEMPLATEEX
  ' la structure etant de taille variable, il faut la determiner 
  sCaption = oWrap.StrGet(pBase + 30)  ' no menu & window class system defaut 
  sFont = oWrap.StrGet(pBase + 38 + LenB(sCaption))
  iDTE = 40 + LenB(sCaption) + LenB(sFont)
  pBase = pBase + iDTE + iDTE mod 4 ' ne pas oublier l'alignement DWORD...
  iOffset = 24
  Do ' traitement des differents controles
    ' offset EndOfData = taille utile du buffer aDataDlg stocke en header (LONG)
	  pEoDD = oWrap.NumGet(oWrap.StrPtr(aDataDlg(iUp)))
    cClass = oWrap.NumGet(pBase,iOffset,"t")
    If cClass = 65535 Then
      sInit = oWrap.StrGet(pBase + iOffset + 4)
      cClass = oWrap.NumGet(pBase,iOffset + 2,"t")
      If (cClass = 133) or (cClass = 128) Then           ' combobox ou button filedlgbox
        ' inclut tous les commandbuttons, pas grave le test filedlgbox se fera dans la dialogproc      
        iID = oWrap.NumGet(pBase,iOffset - 4) 
        BuildDataDlg iID,aDataDlg(iUp),sInit,pEoDD
      End If      
      ' incremente iOffset pour la structure item suivante
      iOffset = iOffset + LenB(sInit) + 32
      iOffset = iOffset + iOffset mod 4  ' alignement DWORD 
    Else  
      sClass = oWrap.StrGet(pBase + iOffset)
      sInit = oWrap.StrGet(pBase + iOffset + LenB(sClass) + 2)
      Select Case sClass
      Case "SysIPAddress32"
         iID = oWrap.NumGet(pBase,iOffset - 4)
         BuildDataDlg iID,aDataDlg(iUp),sInit,pEoDD
      Case "msctls_hotkey32"
        iID = oWrap.NumGet(pBase,iOffset - 4)
        BuildDataDlg iID,aDataDlg(iUp),sInit,pEoDD
      End Select
      ' incremente iOffset
      iOffset = iOffset + LenB(sInit) + LenB(sClass) + 30
      iOffset = iOffset + iOffset mod 4  ' alignement DWORD 
    End If
  Loop Until iOffset >= LenB(sBuf) - iDTE
End Sub
 
Function LoadLayoutFromRes(ByRef sData)
' utilise des donnees ressources binaires crees par un editeur au lieu d'une creation manuelle
' necessite la presence de l'objet adostream ou a defaut l'objet filesystem
' sData : nom d'une constante du script client contenant la ressource encodee en base64 OU nom du fichier ressource
' la presence du fichier est verifiee avant celle de la constante
' valeur renvoyee -
' 0..n : ID du dlg
' -1 : objets ADO.Stream et filesystem absents si sData est un nom de fichier existant
' -2 : fichier et constante inexistants
' -3 : format fichier binaire incorrect
' -4 : erreur initialisation
Const _
adTypeBinary = 1, _
adTypeText = 2
Dim oFile  ' objet fichier filesystem
Dim iUp    ' indice du dlg cree
  If not bInit Then
    If Not Initialize Then
      LoadLayoutFromRes = -4
      Exit Function
    End if
    bInit = True
  End If
  iUp = UBound(DLGTEMPLATEEX) + 1 ' comme DLGTEMPLATEEX a ete cree avec array() renvoie -1 si vide ;)
  ReDim Preserve DLGTEMPLATEEX(iUp)
  DLGTEMPLATEEX(iUp) = oWrap.Space(4096,"")
  ReDim Preserve aDataDlg(iUp)
  On Error Resume Next
  Set oStream = CreateObject("ADODB.Stream")
  If oStream Is Nothing Then
    ' Ado n'existe pas, test filesystem ?
    If oFso Is Nothing Then
      ' si constante pas besoin d'objet stream, DLGTEMPLATEEX est utilise directement
      If VarType(sData) = 8 Then
        B64ToBin sData,DLGTEMPLATEEX(iUp),2
      Else  
        ' abandon pas de constante aucun objet dispo
        LoadLayoutFromRes = -1		 
        Exit Function		 
      End If
    Else
      If oFso.FileExists(sData) Then
        ' fichier existe, lecture du binaire
        Set oFile = oFso.GetFile(sData)
        Set oStream = oFile.OpenAsTextStream(1)
        For iC = 0 to oFile.Size - 1
          oWrap.NumPut Asc(oStream.Read(1)),DLGTEMPLATEEX(iUp),iC + 4,"t"
        Next
        oWrap.NumPut oFile.Size + 4,DLGTEMPLATEEX(iUp) ' maj header avec taille donnees
      Else
        If VarType(sData) = 8 Then ' constante chaine existe, pas de test header a ce stade
          ' objet textstream n'est pas utilisable, DLGTEMPLATEEX est transmis directement
          B64ToBin sData,DLGTEMPLATEEX(iUp),2
        Else
          ' pas de fichier, pas de constante abandon
          LoadLayoutFromRes = -2
          Exit Function
        End If
      End If
    End If
  Else
    With oStream
      .Type = adTypeBinary
      .Open
      ' sData est-il un nom de fichier valide ?
      .LoadFromFile sData
      .Type = adTypeText              ' par defaut le charset est deja unicode
      If .Size = 0 Then               ' fichier absent
        If VarType(sData) = 8  Then   ' constante chaine existe, pas de test header a ce stade
          .CharSet = "Windows-1252"   ' reclame par B64ToStream
          B64ToBin sData,oStream,1
          .Position = 0               ' doit etre raz pour changer le charset
          .CharSet = "Unicode"
        Else
          ' pas de fichier, pas de constante abandon
          LoadLayoutFromRes = -2
          Exit Function
        End If
      End If
      DLGTEMPLATEEX(iUp) = oWrap.Space(2,"") & .ReadText
      oWrap.NumPut .Size + 4,DLGTEMPLATEEX(iUp)
    End With  
  End If
  On Error GoTo 0	
  If VarType(oStream) = 9 Then oStream.Close
  With oWrap
    If .NumGet(DLGTEMPLATEEX(iUp),4) <> -65535 Then ' header structure DLGTEMPLATE incorrect (ne pas confondre avec le header du buffer)
      LoadLayoutFromRes = -3
      Exit Function
    End If
    ' creation du buffer data qui sera eventuellement alimente (fonction ParseBinRes)
    aDataDlg(iUp) = .Space(4096,"") ' buffer 8 Ko pour les donnees init des controles combobox, hotkey, ipcontrol et filedlgbox                                                     
    .NumPut iUp,aDataDlg(iUp),4,"t" ' IDD du dlg
    .NumPut 6,aDataDlg(iUp)         ' maj du header la taille utile du buffer = a celle du header + IDD du dlg -> 4 + 2  
  End With
  ParseBinRes DLGTEMPLATEEX(iUp)
  LoadLayoutFromRes = iUp
End Function
 
Function Show(iIDD,bOnTaskBar)
' affiche le dialogue avec la structure DLGTEMPLATEEX + DLGITEMTEMPLATEEX prealablement cree par CreateForm + AddControl ou LoadLayoutFromRes
' iIDD : ID du dialogue renvoye par CreateForm ou LoadLayoutFromRes
' bOnTaskBar : flag affichage du script dans la barre des taches
' valeur renvoyee : -1 erreur ; 0 fermeture bouton systeme ; 2 touche Esc ; ID du bouton clique si entre 1 et 7
Dim hParent
  Show = -1
  ' composant pas initialise par un appel a CreateForm ou LoadLayoutFromFile donc echec
  If Not bInit Then Exit Function 
  ' check validite IDD
  If (iIDD < 0) Or (iIDD > UBound(DLGTEMPLATEEX)) Then Exit Function
  If bOnTaskBar Then hParent = 0 Else hParent = hWsh
  ' ne pas oublier l'offset header de DLGTEMPLATEEX(iIDD)
  ' renvoie la valeur definie par EndDialog
  Show = oWrap.DialogBoxIndirectParamW(hIns,oWrap.StrPtr(DLGTEMPLATEEX(iIDD)) + 4,hParent,pAdr,aDataDlg(iIDD)) 
End Function
 
Function GetValueFromID(iID,hWndDlg)
' renvoie la valeur du controle iID contenu dans le dlg d'handle hWndDlg, si erreur chaine nulle
Const _
EM_GETLINE = &HC4, _
EM_LINELENGTH = &HC1, _
LB_GETCURSEL = &H188, _
LB_GETTEXT = &H189, _
LB_GETTEXTLEN = &H18A, _
CB_GETCURSEL = &H147, _
CB_GETLBTEXT = &H148, _
CB_GETLBTEXTLEN = &H149, _
BM_GETCHECK = &HF0, _
HKM_GETHOTKEY = &H402, _ 
IPM_GETADDRESS = &H466
Dim hNWnd
Dim sClsName
Dim iLen,iIndex
  GetValueFromID = ""
  ' composant pas initialise par un appel a CreateForm ou LoadLayoutFromFile donc echec
  If Not bInit Then Exit Function 
  With oWrap
    sClsName = .Space(16,"")
    hNWnd = .GetDlgItem(hWndDlg,iID)
    .GetClassNameA hNWnd,sClsName,32
    Select Case sClsName
    Case "Edit"
      iLen = .SendMessageA(hNWnd,EM_LINELENGTH,0,0)
      GetValueFromID = .Space(iLen,"")
      .NumPut iLen,GetValueFromID,0,"t"
      .SendMessageW hNWnd,EM_GETLINE,0,GetValueFromID
    Case "ListBox"
      iIndex = .SendMessageA(hNWnd,LB_GETCURSEL,0,0)
      iLen = .SendMessageA(hNWnd,LB_GETTEXTLEN,iIndex,0)
      GetValueFromID = .Space(iLen + 1,"")
      .SendMessageW hNWnd,LB_GETTEXT,iIndex,GetValueFromID
    Case "ComboBox"
      iIndex = .SendMessageA(hNWnd,CB_GETCURSEL,0,0)
      iLen = .SendMessageA(hNWnd,CB_GETLBTEXTLEN,iIndex,0)
      GetValueFromID = .Space(iLen + 1,"")
      .SendMessageW hNWnd,CB_GETLBTEXT,iIndex,GetValueFromID
    Case "Button"
      GetValueFromID = .SendMessageA(hNWnd,BM_GETCHECK,0,0)
    Case "Static"  'Image
      GetValueFromID = .Space(128,"")
      .GetWindowTextA hNWnd,GetValueFromID,256
    Case "msctls_hotkey32"
      GetValueFromID = .SendMessageA(hNWnd,HKM_GETHOTKEY,0,0)
    Case "SysIPAddress32"
      ' dans cette syntaxe lparam est un pointeur et non une valeur
      .SendMessageW hNWnd,IPM_GETADDRESS,0,GetValueFromID
      GetValueFromID = CStr(.NumGet(GetValueFromID,3,"b")) & "." & CStr(.NumGet(GetValueFromID,2,"b")) & _
                       "." & CStr(.NumGet(GetValueFromID,1,"b")) & "." & CStr(.NumGet(GetValueFromID,0,"b"))
    End Select
  End With
End Function
 
Function SetValueFromID(iID,hWndDlg,vData)
' assigne la valeur vData au controle iID contenu dans le dlg d'handle hWndDlg
' renvoie true si OK
Const _
WM_SETTEXT = &HC, _
LB_SETCURSEL = &H186, _
CB_SETCURSEL = &H14E
Dim hNWnd
Dim sClsName
Dim iLen,iIndex
Dim pData
  SetValueFromID = False ' inutile juste pour la clarte du code
  ' composant pas initialise par un appel a CreateForm ou LoadLayoutFromFile donc echec
  If Not bInit Then Exit Function 
  With oWrap
    sClsName = .Space(16,"")
    hNWnd = .GetDlgItem(hWndDlg,iID)
    .GetClassNameA hNWnd,sClsName,32
    Select Case sClsName
    Case "Edit"
      SetValueFromID = .SendMessageW(hNWnd,WM_SETTEXT,0,vData)
    Case "ListBox"	
	  SetValueFromID = .SendMessageA(hNWnd,LB_SETCURSEL,vData,0)
    Case "ComboBox"
      SetValueFromID = .SendMessageA(hNWnd,CB_SETCURSEL,vData,0)
    Case "Button"
      pData = .GetWindowLongW(hNWnd,GWL_USERDATA)
      If pData > 0 Then ' userdata existe : filedlgbox (a developper) 
      Else ' chkbox, optionbutton et cmdbutton
        SetValueFromID = .SendMessageA(hNWnd,BM_SETCHECK,vData,0)
      End If
    Case "Static"
      SetValueFromID = .SendMessageA(hNWnd,STM_SETIMAGE,IMAGE_BITMAP,.LoadImageW(0,vData,IMAGE_BITMAP,0,0,LR_LOADFROMFILE))
    Case "msctls_hotkey32"
      SetValueFromID = .SendMessageA(hNWnd,HKM_SETHOTKEY,ParseHotKey(vData),0)
    Case "SysIPAddress32" 
      SetValueFromID = .SendMessage(hNWnd,IPM_SETADDRESS,0,ParseIPStr(vData)) ' syntaxe lparam DWORD
    End Select
  End With
End Function 
 
Function AddItem(iID,hWndDlg,sData,iIndex)
' ajoute un item sData a un ctrl listbox ou combobox au rang iIndex (base 0) - dernier si -1 
' renvoie le rang effectif ou -1 si erreur
Const LB_INSERTSTRING = &H181, _
CB_INSERTSTRING = &H14A
Dim hNWnd
Dim sClsName
  AddItem = -1
  ' composant pas initialise par un appel a CreateForm ou LoadLayoutFromFile donc echec
  If Not bInit Then Exit Function 
  With oWrap
    sClsName = .Space(16,"")
    hNWnd = .GetDlgItem(hWndDlg,iID)
    .GetClassNameA hNWnd,sClsName,32
    Select Case sClsName
    Case "ListBox"
      AddItem = .SendMessageW(hNWnd,LB_INSERTSTRING,iIndex,sData)
    Case "ComboBox"
      AddItem = .SendMessageW(hNWnd,CB_INSERTSTRING,iIndex,sData)
    End Select
  End With
End Function
 
Function RemoveItem(iID,hWndDlg,iIndex)
' retire un item de rang iIndex dans un ctrl listbox ou cbbox
' renvoie le nb d'items restant ou -1 si erreur
Const LB_DELETESTRING = &H182, _
CB_DELETESTRING = &H144
Dim hNWnd
Dim sClsName
  RemoveItem = -1
  ' composant pas initialise par un appel a CreateForm ou LoadLayoutFromFile donc echec
  If Not bInit Then Exit Function 
  With oWrap
    sClsName = .Space(16,"")
    hNWnd = .GetDlgItem(hWndDlg,iID)
    .GetClassNameA hNWnd,sClsName,32
    Select Case sClsName
    Case "ListBox"
      RemoveItem = .SendMessageA(hNWnd,LB_DELETESTRING,iIndex,0)
    Case "ComboBox"
      RemoveItem = .SendMessageA(hNWnd,CB_DELETESTRING,iIndex,0)
    End Select
  End With
End Function
 
Const imgWScript = <code disponible dans le script à télécharger dans la page précédente>
Const imgDynWrapX = <code disponible dans le script à télécharger dans la page précédente>
</script>
</component>

précédentsommaire

Vous avez aimé ce tutoriel ? Alors partagez-le en cliquant sur les boutons suivants : Viadeo Twitter Facebook Share on Google+   

  

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2011 omen999. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents, images, etc. sans l'autorisation expresse de l'auteur. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.