Modifier paramètres objet Paint

[yannick64]

Bonsoir à tous,

Je cherche à intégrer dans une feuille excel une signature. Pour réussir j'ai essayé plusieurs méthodes et celle qui me parait la plus intéressante et d'utiliser "insertion objet - Bitmap" qui m'ouvre Paint.
Mon souci c'est que je n'arrive pas à définir la taille de mon image depuis Excel et quand je modifie les paramètres dans Paint ils ne sont pas sauvegardés pour la fois suivante.
Ma question est de savoir s'il y à un moyen de définir directement en VBA les caractéristiques dimensionnelle de ma zone de signature...

Voici le code que j'utilise :

ActiveSheet.OLEObjects.Add(ClassType:="Paint.Picture", Link:=False, _
        DisplayAsIcon:=False, Left:=340, Top:=30, Width:=350, Height:=155).Activate

Merci pour votre aide !
Yannick

 

[PMO2]

Re : Modifier paramètres objet Paint

Bonjour,

Dans la mesure où j'ai compris, essayez le code suivant qui vous demandera de sélectionner une plage de cellules dans laquelle viendra s'inscrire l'objet Paint

Sub aa()
Dim R As Range
Dim OL As OLEObject
'---
On Error GoTo Erreur
Set R = Application.InputBox(prompt:="Sélectionnez un cellule ou une plage. Le cadre signature viendra s'y intégrer", Type:=8)
'---
Set OL = ActiveSheet.OLEObjects.Add(ClassType:="Paint.Picture")
With OL
  .Top = R.Top
  .Left = R.Left
  .Width = R.Width
  .Height = R.Height
End With
'---
Erreur:
End Sub

 

[yannick64]

Re : Modifier paramètres objet Paint

Merci je vais tester ça !

 

[yannick64]

Re : Modifier paramètres objet Paint

Merci PMO2,

Ce code résout une partie de mon problème la taille de la zone et son emplacement, mais en crée un autre Paint ne s'ouvre pas il intègre directement une image vide dans l'emplacement prédéfini ce qui ne me permet pas de faire la signature à intégrer.

Ce ne doit pas être grand chose mais je bloque.

Merci par avance
Yannick

 

[PMO2]

Re : Modifier paramètres objet Paint

Il faut faire un double clic sur l'OLEObject pour que Paint obtienne le focus. Vous pourrez alors dessiner dedans.

 

[yannick64]

Re : Modifier paramètres objet Paint

ah effectivement je n'avais pas essayé de double cliquer...

Merci encore !
Yannick

 

[yannick64]

Re : Modifier paramètres objet Paint

Encore un petit problème...

Je ne sais pas si c'est spécifique à mon ordinateur mais a chaque fois que je double clique sur la zone image et que Paint s'ouvre la taille de l'image dans Paint est différente de celle d'excel (plus petite et carrée). Même en modifiant les paramètres de Paint ça ne change rien. Est ce que le problème est le même chez vous???lot demain
Je vais essayer au boulot demain

Bonne fin de soirée
Yannick

 

[yannick64]

Re : Modifier paramètres objet Paint

Bonjour à tous,

Le problème venait bien de mon PC, sur un autre PC Paint garde en mémoire la taille définie.

Du coup j'aurais voulu maintenant faire la même chose avec un UserForm. Est ce que c'est possible d'intégrer cette fonctionnalité dans un UserForm?

Merci pour votre aide
Yannick

 

[PMO2]

Re : Modifier paramètres objet Paint

**************

 

[yannick64]

Re : Modifier paramètres objet Paint

**************

Pourquoi avez vous supprimé votre message?

Qu'est ce que les APIs dans Excel, je n'ai jamais entendu parler de ça?

Merci
Yannick

 

[Staple1600]

Re : Modifier paramètres objet Paint

Bonjour à tous

Je cherche à intégrer dans une feuille excel une signature.

Par signature, tu entends quoi ?
1) une image scannée et figée (ou un fichier image toujours identique)
ou
2) une image modifiable à la volée ensuite insérée dans Excel

Si 1) alors tu peux utiliser au choix ces deux syntaxes

Sub TestI()
Dim SignatureImgPath$
ImgPath$ = "C:\Users\Abc\Pictures\testpict.png"
ActiveSheet.Pictures.Insert ImgPath
End Sub

Sub TestII()
Dim Signature As Shape, ImgPath$
ImgPath$ = "C:\Users\Abc\Pictures\testpict.png"
Set Signature = ActiveSheet.Shapes.AddPicture(ImgPath, False, True, 0, 0, -1, -1)
'Avec le paramètre LinkToFile sur True l'image est liée -> cf l'URL ci-dessous
'Set Signature = ActiveSheet.Shapes.AddPicture(ImgPath, True, True, 0, 0, -1, -1)
End Sub

Ce lien n'existe plus pour plus de détails

NB: Pensez à adapter ImgPath avec le chemin correct vers le fichier image désiré.

 

[PMO2]

Re : Modifier paramètres objet Paint

Bonjour,

yannick64
Pourquoi avez vous supprimé votre message?

J'ai supprimé mon précédent message car il restait sans réaction et semblait n'intéresser personne.
Comme je le disais, c'est difficile à mettre en oeuvre et à expliquer.
Bien qu'on puisse faire beaucoup de choses avec VBA, il y en a énormément qui ne peuvent l'être.
On est obligé de passer par de la programmation Windows en utilisant les APIs windows à partir de l'environnement de développement VBA (VBE). Cela ne marche qu'avec un système d'exploitation Windows (cela ne va pas le faire avec un MAC).

J'indique un lien pour que vous appréhendiez ce que sont les APIs
Windows API — Wikipédia

Staple1600
2) une image modifiable à la volée ensuite insérée dans Excel

Je pense que c'est la 2 qui fait l'objet de la demande.

*************************
J'ai essayé de faire au plus simple.
Voilà la démarche
1) Créez un UserForm1 avec une Frame1 et 3 CommandButton (CommandButton1, CommandButton2, CommandButton3)
2) Copiez le code suivant dans la fenêtre de code de UserForm1

Private Sub CommandButton1_Click()
Frame1.Repaint
End Sub

Private Sub CommandButton2_Click()
'--- Réduit le UserForm à la taille de la Frame ---
Me.Width = Frame1.Width
Me.Height = Frame1.Height
'--- Libère le presse-papiers ---
OpenClipboard 0&
EmptyClipboard
CloseClipboard
'--- Copie et colle la fenêtre active ---
keybd_event vbKeySnapshot, 1&, 0&, 0&
On Error Resume Next
Do
  Err.Clear
  DoEvents
  Sheets(1).Paste
Loop Until Err = 0
On Error GoTo 0
'--- Décharge l'USF ---
Unload Me
End Sub

Private Sub CommandButton3_Click()
Unload Me
End Sub

Private Sub Frame1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Button = 1 Then SetDrawStart x, y
End Sub

Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Button = 1 Then Draw x, y
End Sub

Private Sub UserForm_Activate()
Dim Hndl&
'--- Retire la barre titre de l'USF ---
Hndl& = FindWindow("Thunder" & IIf(Application.Version Like "8*", "0*", "D") & "Frame", UserForm1.Caption)
SetWindowLong Hndl&, -16, GetWindowLong(Hndl&, -16) And Not &HC00000
End Sub

Private Sub UserForm_Initialize()
Const PointsParPouce As Long = 72  '1 Inch = 72 Points [Postscript] | 1 Point = 0.01388888889 Inch
'---
X_Coeff2Points# = PointsParPouce / GetDeviceCaps(GetDC(Application.hWnd), LOGPIXELSX)
Y_Coeff2Points# = PointsParPouce / GetDeviceCaps(GetDC(Application.hWnd), LOGPIXELSY)
ReleaseDC 0, myHdc&
myHdc& = GetDC(UserForm1.Frame1.[_GethWnd])
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
ReleaseDC UserForm1.Frame1.[_GethWnd], myHdc&
End Sub

3) Copiez le code suivant dans un module Standard

'### APIs ###
Declare Function GetDC& Lib "user32.dll" ( _
  ByVal hWnd&)
Declare Function ReleaseDC& Lib "user32.dll" ( _
  ByVal hWnd&, ByVal hdc&)
Declare Function GetDeviceCaps& Lib "gdi32.dll" ( _
  ByVal hdc&, ByVal nIndex&)
Declare Function LineTo& Lib "gdi32.dll" ( _
  ByVal hdc&, ByVal x&, ByVal y&)
Declare Function MoveToEx& Lib "gdi32.dll" ( _
  ByVal hdc&, ByVal x&, ByVal y&, lpPoint As POINTAPI)
'---
Declare Sub keybd_event Lib "user32.dll" ( _
  ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags&, ByVal dwExtraInfo&)
Declare Function CloseClipboard& Lib "User32" ()
Declare Function OpenClipboard& Lib "User32" (ByVal hWnd&)
Declare Function EmptyClipboard& Lib "User32" ()
Declare Function SetActiveWindow& Lib "user32.dll" (ByVal hWnd&)
'---
Declare Function FindWindow& Lib "User32" Alias "FindWindowA" ( _
  ByVal lpClassName$, ByVal lpWindowName$)
Declare Function SetWindowLong& Lib "user32.dll" Alias "SetWindowLongA" ( _
  ByVal hWnd&, ByVal nIndex&, ByVal dwNewLong&)
Declare Function GetWindowLong& Lib "user32.dll" Alias "GetWindowLongA" ( _
  ByVal hWnd&, ByVal nIndex&)

'### Constante et Type API ###
Public Const LOGPIXELSX As Long = 88  'Number of pixels per logical inch along the screen width
Public Const LOGPIXELSY As Long = 90  'Number of pixels per logical inch along the screen height
Type POINTAPI
  x As Long
  y As Long
End Type

'### Variables publiques ###
Public PositionMouse As POINTAPI
Public myHdc&
Public X_Coeff2Points#
Public Y_Coeff2Points#

Sub SetDrawStart(ByVal x As Long, ByVal y As Long)
MoveToEx myHdc&, x / X_Coeff2Points#, y / Y_Coeff2Points#, PositionMouse
End Sub

Sub Draw(ByVal x As Long, ByVal y As Long)
LineTo myHdc&, x / X_Coeff2Points#, y / Y_Coeff2Points#
End Sub

Il n'y a plus qu'à lancer le UserForm.
Je ne suis pas capable de fournir d'explication car il il faut que vous possédiez un minimum de connaissances des APIs.

Je mets un classeur exemple pour faciliter.

 

[yannick64]

Re : Modifier paramètres objet Paint

Merci Staple1600 et PM02,

Effectivement ma demande porte sur une image modifiable à la volée dans un Userform.

Je vais essayer la solution de PM02

En tout cas merci a vous pour votre aide !!!
Yannick

 

[yannick64]

Re : Modifier paramètres objet Paint

Au risque de passer pour un gros boulet je reviens vers vous...

J'ai testé ce Userform et je dois vraiment pas être doué mais je n'arrive pas à modifier l'image, ni par double clic ni par déplacement de souris...

y a t'il une astuce que je n'aurai pas saisi???

Encore désolé

 

[PMO2]

Re : Modifier paramètres objet Paint

Bonjour,

Si vous visualisez le UserForm comme dans l'image suivante

il faut faire, sur la zone blanche (Frame), la même démarche que dans Paint pour dessiner : clic gauche maintenu et déplacement souris.

Causes éventuelles de dysfonctionnement :
1) Vous avez Excel en 64 bits. Dans ce cas, il faut revoir toutes les déclarations APIs (Declare)
2) Vous utilisez autre chose que la souris (stylo électronique). Je ne peux pas reproduire le cas, je n'ai qu'une souris classique.
3) Vous êtes sous MAC, les APIs ne sont pas prises en compte.

J'ai vu que d'autres personnes ont téléchargé l'exemple, peuvent-elles nous dire si cela fonctionne chez elles ?
Pour ma part, tout fonctionne chez moi.