Eleasias
Messages postés36Date d'inscriptionmardi 18 mars 2008StatutMembreDernière intervention31 mars 2008
-
28 mars 2008 à 09:21
Eleasias
Messages postés36Date d'inscriptionmardi 18 mars 2008StatutMembreDernière intervention31 mars 2008
-
28 mars 2008 à 09:28
Je suis novice comme certains le savent déjà et je dois faire une macro VBA dans le cadre de mon stage.
Quelques un d'entre vous m'ont déjà aidé et je les en remercie.
Il faut que je fasse une fenêtre que charge mes 2 graphes en JPEG dedans (ouvert par une autre userform avant).
J'ai voulu mettre comme outil : - une "croix" qui prend toute mon image et qui suit le curseur.
- un code me permettant d'afficher une fenêtre classique (redimentionner, agrandir, réduire...)
- un zoom réglable par l'utilisateur
- un aperçu avant impression (ça marche très bien)
- 2 bouton ouvrir indépendants (un sur chaque image) qui s'affiche après 2-3s si le curseur sur l'image ne bouge pas et disparaît au bout de 6-7s si le curseur ne va pas sur le bouton
Ma userform1 contient : - textbox1 pour rentrer une valeur de zoom (entre 0 et 400)
- commandbutton1 pour actualiser le zoom
- commandbutton2 : aperçu avant impression (ca marche pas de pb)
- frame 1 et frame 2 où sont affichées mes images
- à l'intérieur il y a dans chacune respectivement : - commandbutton3 et commandbutton4 (caption : Copier
- 2images appelées Line1, Line2 et Line3, Line4
Je sais que c'est un gros pavé à avaler mais là je commence à ramer.
Je vais vous donner mon code actuel et après je vous soumettrai, si vous le voulez bien, quelques petites choses que j'aimerai améliorer
Dans ma userform1
----------------------
Public CustomProperties As UFCustomProperties
'*** Initialisation des propriétés de la fenêtre ***
Private Sub UserForm_Activate()
Set CustomProperties = New UFCustomProperties
Me.CustomProperties.Initialisation 'Acquisition du Handle de la Userform
Me.CustomProperties.FullSizing
Me.Left = Me.Left + 1
Me.Left = Me.Left - 1
SetupLines
With UserForm1
.StartUpPosition = 3
.Width = Application.Width
.Height = Application.Height
.Left = 0
.Top = 0
End With
End Sub
Private Sub CommandButton1_Click()
UserForm1.ScrollTop = 0
UserForm1.ScrollLeft = 0
On Error GoTo err
UserForm1.Zoom = TextBox1.Value
err:
If err.Number <> 0 Then
If err.Number <> 13 Then
MsgBox "Erreur : " & err.Number & vbCrLf & err.Description
End If
End If
End Sub
Private Sub Line1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CursorMoved X, Line1.Top
End Sub
Private Sub Line2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CursorMoved Line2.Left, Y
End Sub
Private Sub Line3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CursorMoved2 Line3.Top, X
End Sub
Private Sub Line4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CursorMoved2 Line4.Left, Y
End Sub
Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CursorMoved X, Y
If mhTimer Then
KillTimer 0, mhTimer
End If
mhTimer = SetTimer(0, 0, 1300, AddressOf TimerProc)
End Sub
Private Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CursorMoved2 X, Y
If mhTimer Then
KillTimer 0, mhTimer
End If
mhTimer = SetTimer(0, 0, 1300, AddressOf TimerProc)
End Sub
Private Sub CursorMoved(ByVal X As Single, ByVal Y As Single)
Line1.Top = Y
Line2.Left = X
End Sub
Private Sub CursorMoved2(ByVal X As Single, ByVal Y As Single)
Line3.Top = Y
Line4.Left = X
End Sub
Private Sub SetupLines()
Line1.Left = 0
If Me.Zoom <> 100 Then
Line1.Width = 100 * Me.Width / (100 - Me.Zoom)
Else
Line1.Width = Me.Width
End If
Line1.Height = 1
Line1.ZOrder 0
Line1.BorderColor = vbBlack
Line2.Top = 0
If Me.Zoom <> 100 Then
Line2.Height = 100 * Me.Height / (100 - Me.Zoom)
Else
Line2.Height = Me.Height
End If
Line2.Width = 1
Line2.ZOrder 0
Line2.BorderColor = vbBlack
Line3.Left = 0
If Me.Zoom <> 100 Then
Line3.Width = 100 * Me.Width / (100 - Me.Zoom)
Else
Line3.Width = Me.Width
End If
Line3.Height = 1
Line3.ZOrder 0
Line3.BorderColor = vbBlack
Line4.Top = 0
If Me.Zoom <> 100 Then
Line4.Height = 100 * Me.Height / (100 - Me.Zoom)
Else
Line4.Height = Me.Height
End If
Line4.Width = 1
Line4.ZOrder 0
Line4.BorderColor = vbBlack
End Sub
Private Sub UserForm_Terminate()
If mhTimer Then
KillTimer 0, mhTimer
End If
End Sub
Dans un module
------------------
Public Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public mhTimer As Long
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
Dans un module de classe nommé UFCustomProperties
-----------------------------------------------------
'*** Définitions des variables locales & fonctions ***
' Fonction d'acquisition de l'identifiant de la fenêtre active
Private Declare Function GAW Lib "user32" Alias "GetActiveWindow" () As Long
' Fonction d'acquisition du titre de la Window hwnd
Private Declare Function GWT Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
' Fonction de changement du titre de la Window hwnd (si existant)
Private Declare Function SWT Lib "user32" Alias "SetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String) As Boolean
' Fonction d'acquisition
Private Declare Function GWL Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
' Fonction de changement
Private Declare Function SWL Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
' Déclaration des variables internes
Private Const GWL_STYLE As Long = -16
Private Const WS_THICKFRAME = &H40000 'Cadre fin pour redimensionnement
Private stTmp As String, lgTmp As Long, lgRet As Long, Whdl As Long
'*** Acquisition du Handle de la Userform ***
'*** pour initialisation ***
Public Function Initialisation()
Whdl = GAW
End Function
'*** Définition des propriétés ***
' Bouton Agrandir
Public Property Get MaximizeBox() As Boolean
OldProp = GWL(Whdl, GWL_STYLE) 'Acquisition propriétés
If OldProp = (OldProp Or WS_MAXIMIZEBOX) Then
MaximizeBox = True
Else
MaximizeBox = False
End If
End Property
Public Property Let MaximizeBox(Enable As Boolean)
If MaximizeBox <> Enable Then
OldProp = GWL(Whdl, GWL_STYLE) 'Acquisition propriétés
SWL Whdl, GWL_STYLE, OldProp Xor WS_MAXIMIZEBOX 'Changement propriétés
End If
End Property
' Bouton Réduire
Public Property Get MinimizeBox() As Boolean
OldProp = GWL(Whdl, GWL_STYLE) 'Acquisition propriétés
If OldProp = (OldProp Or WS_MINIMIZEBOX) Then
MinimizeBox = True
Else
MinimizeBox = False
End If
End Property
Public Property Let MinimizeBox(Enable As Boolean)
If MinimizeBox <> Enable Then
OldProp = GWL(Whdl, GWL_STYLE) 'Acquisition propriétés
SWL Whdl, GWL_STYLE, OldProp Xor WS_MINIMIZEBOX 'Changement propriétés
End If
End Property
' Etat Agrandi
Public Property Get Maximized() As Boolean
OldProp = GWL(Whdl, GWL_STYLE) 'Acquisition propriétés
If OldProp = (OldProp Or WS_MAXIMIZED) Then
Maximized = True
Else
Maximized = False
End If
End Property
' Etat Réduit
Public Property Get Minimized() As Boolean
OldProp = GWL(Whdl, GWL_STYLE) 'Acquisition propriétés
If OldProp = (OldProp Or WS_MINIMIZED) Then
Minimized = True
Else
Minimized = False
End If
End Property
' Cadre de re-dimensionnement
Public Property Get ThickFrame() As Boolean
OldProp = GWL(Whdl, GWL_STYLE) 'Acquisition propriétés
If OldProp = (OldProp Or WS_THICKFRAME) Then
ThickFrame = True
Else
ThickFrame = False
End If
End Property
Public Property Let ThickFrame(Enable As Boolean)
If ThickFrame <> Enable Then
OldProp = GWL(Whdl, GWL_STYLE) 'Acquisition propriétés
SWL Whdl, GWL_STYLE, OldProp Xor WS_THICKFRAME 'Changement propriétés
End If
End Property
' Tous les attributs de Re-dimensionnement
Public Function FullSizing()
End Function
' Changement de titre
' ATTENTION: L'utilisation de la propriété "Caption" pour changer
' le titre de la fenêtre inhibe les boutons "Agrandir" & "Réduire"
Public Property Get Title() As String
'Acquisition Titre pour cohérence avec changement
'la propriété "Caption" peut être utilisée pour
'acquérir le titre de la Userform
stTmp = Space$(120)
lgTmp = 119
GWT Whdl, stTmp, lgTmp
Title = stTmp
End Property
Public Property Let Title(NewTitle As String)
SWT Whdl, NewTitle
End Property
J'aimerai que les boutons ouvrir marchent, car avec un code que l'on ma fournit (sur ce site) j'arrive juste à faire apparaître un bouton, mais ni les 2 indépendamment ni les faire disparaître.
Et aussi si possible arranger les petits problèmes de bug avec la croix (d'un coup le centre de la croix n'est plus sur le curseur).
J'aimerai aussi pouvoir, quand je réduis la fenêtre (UserForm1) qu'elle s'affiche dans la barre des tâches, et pouvoir ouvrir deux fenêtre de type Userform1 (je ne comprend pas du tout comment faire fonctionner le MODAL).
Merci par avance pour ceux qui en sont arrivés jusqu'ici, car il faut du courage. J'ai essayé de résoudre ces problèmes indépendamment mais je n'y arrive pas.
Peut être qu'avec l'intégralité de mon projet vous y verrez plus clair.
Eleasias
Messages postés36Date d'inscriptionmardi 18 mars 2008StatutMembreDernière intervention31 mars 2008 28 mars 2008 à 09:28
Petite précision : le code que m'a donné Renfield avant que je ne le saccage est le suivant :
UserForm:
-----------------------
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If mhTimer Then
KillTimer 0, mhTimer
End If
mhTimer = SetTimer(0, 0, 3000, AddressOf TimerProc)
End Sub
Private Sub UserForm_Terminate()
If mhTimer Then
KillTimer 0, mhTimer
End If
End Sub
--------------------------
Public Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public mhTimer As Long
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
KillTimer 0, mhTimer
mhTimer = 0
UserForm1.CommandButton1.Visible = True
End Sub
Si cela vous éclaire un peu plus sur des zones sombre de ce code, c'est tant mieux