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>