WILFRIED
XLDnaute Impliqué
Bonjour,
J'étais à la recherche d'une méthode pour sauvegarder un activeX (mscal.ocx) dans un fichier excel quand j'ai trouver ce code :
qui créer un espèce de calendrier...
Et ce code :
Je n'ai pas réussit a décortiquer ces codes si quelqu'un pouvait éclairer ma lanterne afin de pouvoir l'adapter a mon projet.
D'avance merci,
J'étais à la recherche d'une méthode pour sauvegarder un activeX (mscal.ocx) dans un fichier excel quand j'ai trouver ce code :
Code:
Option Explicit
Private Declare Function CreateWindowEx Lib "user32" Alias _
"CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String _
, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long _
, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long _
, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long _
, lpParam As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long _
, lParam As Any) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long _
, ByVal hWndNewParent As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private dtHwnd As Long
Private Sub CommandButton1_Click()
Dim CurSysTime As SYSTEMTIME
SendMessage dtHwnd, &H1001, 0&, CurSysTime
With CurSysTime
TextBox1 = Format(DateSerial(.wYear, .wMonth, .wDay), "Short Date")
ActiveCell = CDate(TextBox1)
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
DestroyWindow dtHwnd
End Sub
Private Sub UserForm_Initialize()
Dim meHwnd As Long, h&
h = GetSystemMetrics(51)
meHwnd = FindWindow(vbNullString, Me.Caption)
dtHwnd = CreateWindowEx(0, "SysMonthCal32", vbNullString, _
&H50000000, 4, -h, 200, 200, meHwnd, 0&, 0&, ByVal 0&)
SetParent dtHwnd, meHwnd
Me.Width = (Me.Width - Me.InsideWidth) + 208 * 3 / 4
TextBox1.Top = (200 - h) * 3 / 4: TextBox1.ZOrder 0
TextBox1.Height = 18
TextBox1.Left = 6
TextBox1.Width = 90
CommandButton1.Top = TextBox1.Top
CommandButton1.Left = TextBox1.Left + TextBox1.Width + 6
CommandButton1.Height = 18
CommandButton1.Width = 48
CommandButton1.Caption = "OK"
CommandButton1.ZOrder 0
Me.Height = TextBox1.Top + TextBox1.Height + GetSystemMetrics(4) + 6
Me.Width = CommandButton1.Left + 6 + CommandButton1.Width + GetSystemMetrics(7) * 3 / 2
End Subqui créer un espèce de calendrier...
Et ce code :
Code:
sub InstallationFichierOcxOuDLL()
'prend soin d'indiquer le nom de la dll que tu joindras au fichier excel.
'Dans le ThisWorkbook :
Private sub Workbook_Open()
sub InstallationFichierOcxOuDLL()
end sub
'Dans le haut d'un module standard :
Private Declare Function GetSystemDirectory Lib "kernel32.dll" Alias _
"GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Function CheminSystem()
Dim RetVal As Long
Dim SysDir As String
SysDir = Space$(256)
RetVal = GetSystemDirectory(SysDir, Len(SysDir))
If RetVal <> 0 Then
CheminSystem = Left$(SysDir, RetVal)
End If
End Function
'Dans un module standard :
sub InstallationFichierOcxOuDLL()
Dim FichierSource As String, FichierCible As String
Dim OcxFile As String, Chemin As String
OcxFile = "Msmask32.ocx"
Chemin = CheminSystem & ""
FichierSource = ThisWorkbook.Path & "" & OcxFile
FichierCible = Chemin & OcxFile
'Vérifie la présence de .oxc,dll dans le fichier système
If Dir(FichierCible) = "" Then
'Si pas trouvé,
'Vérifier que ce "ocx" est présent dans le même
'répertoire que ce fichier (ThisWorkbook.path)
'Afin de le copier dans le répertoire système de
'de l'ordinateur de l'usager
If Dir(FichierSource) = "" Then
MsgBox "Le ficher " & OcxFile & " n'est pas dans " & _
"le même répertoire de ce classeur! Vérifier !" & vbCrLf & vbCrLf & _
"Afin d'assurer le bon fonctionnement des processus" & vbvrlf & _
" d'automation de ce fichier, copier le fichier" & vbCrLf & _
" manquant le répertoire suivant : " & Chemin & vbCrLf & vbCrLf & _
"Ce classeur se fermera à la fermeture de cette fenêtre.", _
vbCritical + vbOKOnly, "Info utilisateur"
ThisWorkbook.Close False
End If
'Copie du fichier ocx vers le répertoire système
FileCopy FichierSource, FichierCible
'Initialisation de l'ocx dans la base de registre
Shell Chemin & "regsvr32.exe " & OcxFile & " /s"
'Ajouter la référence au projet
Application.VBE.ActiveVBProject.References.AddFromFile FichierCible
End If
end subJe n'ai pas réussit a décortiquer ces codes si quelqu'un pouvait éclairer ma lanterne afin de pouvoir l'adapter a mon projet.
D'avance merci,
