Calcul de la surface d'un Shape

Bonsoir,
s'il s'agit de la surface occupée par les poignées de
recopie alors :
Shapes("zaza").width *shapes("zaza").height
je n'ai pas vérifié si cela reste vrai en cas de
rotation...

s'il s'agit de la surface coloré du shape :
quelques problemes à identifier :
notament forme du shape :
a - forme simple( triangle, parallélogramme, ellipse)
connaissant les coordonnées quelques formules de
géométrie devrait permettre la solution.
b - forme simple décomposable en figure géometrique
élementaire.
c - forme de révolution.
d - forme aléatoire.

pour le cas b :
il me semble avoir aperçu un programme excel (chez un guru
américain "Tushar Meta" ???) qui faisait ça, je vais
essayer de retrouver.

pour les autres cas, cela peut etre un challenge pour
notre ami Serge "Garnote"

;-)))
@+

-----Message d'origine-----
Bonjours a tous et a toutes
Je cherche à calculer la surface en pixel d'un Shape en
VB

sous Excel

Cela fait pas mal de temps que je cherche et je ne trouve
pas...

Par avance merci.
Marc
.

Bonsoir Marc,
Tu as sans doute déjà essayé des trucs de ce genre ?

Sub surface_en_chaipakoi()
'sans garantie sur l'unité dans laquelle se fait le calcul
Dim lg As Integer, ht As Integer, surf As Long
'
lg = ActiveSheet.Shapes("Rectangle 1").Width
ht = ActiveSheet.Shapes("Rectangle 1").Height

surf = lg * ht
MsgBox surf
End Sub

--
Amicales Salutations
A_S_rauphil@wanadoo.fr
Retirer A_S_ pour répondre.
XL97 / XL2002
"Marc" <nospam-maverick41@caramail.com> a écrit dans le message de
news:094201c34b9c$032fee00$a601280a@phx.gbl...
Bonjours a tous et a toutes
Je cherche à calculer la surface en pixel d'un Shape en VB
sous Excel

Cela fait pas mal de temps que je cherche et je ne trouve
pas...

Par avance merci.
Marc

Bonsoir,
J'ai briocolé la proc du classeur <gd-gidipad> de GeeDee.
Il faut enregistrer les coordonnées des cotes de la surface à mesurer,
selon les règles de la géometrie.
Une surface de formes complexe peut être "découpée" en plusieures parties.
Après chaque partie, faire <Escape>, puis cliquer <Annuler> pour avoir les surfaces
des différentes parties.

Voici l'aide de GeeDee:

Bonjour voici la tablette à numériser de GeeDee !!!
(modifiée par ajf)
Utilisation :
1- ajouter une feuille
2- inserer une image représentant la courbe ou l'objet
dont on désire récupérer les coordonnées.
3- agrandir cette image à la taille optimum visible de cette fenetre
(pour une meilleure précision).
4- activer la macro SaisieXY par Alt + F8
5- placer successivement le curseur de la souris sur les points à capturer,
en appuyant à chaque fois sur <<Entrée>>
6- <<Escape>> pour arrêter.
6 bis- <<Annuler>> pour prendre les coordonnées d'une autre surface
Nota :
Les coordonnées saisies s'inscriront en colonnes A et B.
Les coordonnées sont en pixels et proportionnelles aux dimensions de l'image.
Les coordonnées sont fonction de la résolution d'écran utilisée.
Rappel :
les X demarrent (0) à gauche de l'écran.
les Y démarrent (0) en haut de l'écran.
'*************************
Option Base 1
Option Explicit
Public Pointeur As POINTAPI
Public Reponse
Declare Function GetCursorPos Lib "USER32" (lpPoint _
As POINTAPI) As Long
Declare Function GetSystemMetrics Lib "USER32" _
(ByVal nIndex As Long) As Long

'********************************************************************
'* DECLARE WINDOWS 32-BIT API CALLS *
'********************************************************************
'Type to hold the x and y coordinates of the mouse pointer
Type POINTAPI
x As Long
y As Long
End Type
'Type to hold the Windows message information
Type MSG32
hWnd As Long 'the window handle of the app
message As Long 'the type of message (e.g. keydown, keyup etc)
wParam As Long 'stores the key code
lParam As Long '?
time As Long 'time when message posted
pt As POINTAPI 'coordinate of mouse pointer when messahe posted
End Type
'Find the window handle for this instance of Excel
Declare Function FindWindow32 Lib "USER32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
'Look in the message buffer for a message
Declare Function PeekMessage32 Lib "USER32" _
Alias "PeekMessageA" (lpMsg As MSG32, _
ByVal hWnd As Long, ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
'Translate the message from a virtual key code to a ASCII code
Declare Function TranslateMessage32 Lib "USER32" _
Alias "TranslateMessage" (lpMsg As MSG32) As Long
'********************************************************************
'* Procedure basée sur la fonction *
'* CHECK FOR A KEY PRESS *
'* By Stephen Bullen, Stephen@BMSLtd.co.uk *
'* Modifié par Ajf 16.07.2003 *
'********************************************************************
Sub SaisieXY()
Dim iCount As Integer
Dim sKey As String

Dim cnt As Integer
Dim tbl As Variant
Dim carre1, carre2
ReDim tbl(100, 2)
Application.DisplayStatusBar = True
Application.StatusBar = "Déplacez la souris !!!"
iCount = 2
Reponse = MsgBox("En pressant la touche <<Entrée>>" _
& Chr(10) & _
"les coordonnées apparaissant en bas à gauche seront mémorisées", _
vbInformation, "GD_DigiPad")
'Just loop until a key is pressed
encore:
Application.Cursor = xlNorthwestArrow
Do
GetCursorPos Pointeur
Application.StatusBar = _
"Point N°" & iCount & " X=" & Pointeur.x & " Y=" & Pointeur.y
'Call the appropriate routine to check the keyboard buffer
sKey = funCheckKey32
Loop Until sKey <> ""
'------test si la touche escape à été activée
If sKey = Chr(27) Then
Reponse = MsgBox("Fin de capture ???" & vbLf & vbLf & _
"si vous desirez créer une nouvelle série " & _
"de coordonnées sans écraser les anciennes" & vbLf & _
"cliquez sur <Annuler> ", vbYesNoCancel + vbQuestion, "GD_DigiPad")
If Reponse <> vbNo Then ' ----------c'est vraiment fini
If Reponse = vbYes Then
Application.Cursor = xlDefault
Application.StatusBar = False
Exit Sub
Else '---------bouton <Annuler> pour une nlle série sans écraser

ActiveSheet.Cells(iCount, 1).Value = "X (horizontal)"
ActiveSheet.Cells(iCount, 2).Value = "Y (vertical)"
iCount = iCount + 1
End If

End If
End If
'------test si la touche entree a été activée
If sKey = Chr(13) Then
ActiveSheet.Cells(1, 1).Value = "X (horizontal)"
ActiveSheet.Cells(1, 2).Value = "Y (vertical)"
ActiveSheet.Cells(1, 3).Value = "Coordonnée n° "
ActiveSheet.Cells(1, 4).Value = "amplitude x "
ActiveSheet.Cells(1, 5).Value = "amplitude y "
ActiveSheet.Cells(1, 6).Value = "long. des cotés"
ActiveSheet.Cells(1, 7).Value = ""
ActiveSheet.Cells(1, 8).Value = "aire (pixels) "
cnt = cnt + 1
ActiveSheet.Cells(iCount, 1).Value = Pointeur.x
ActiveSheet.Cells(iCount, 2).Value = Pointeur.y
ActiveSheet.Cells(iCount, 3).Value = cnt
tbl(cnt, 1) = Pointeur.x
tbl(cnt, 2) = Pointeur.y
If cnt / 2 = Int(cnt / 2) Then
Cells(iCount, 4) = Abs(tbl(cnt, 1) - tbl(cnt - 1, 1))
Cells(iCount, 5) = Abs(tbl(cnt, 2) - tbl(cnt - 1, 2))
carre1 = Cells(iCount, 4) ^ 2
carre2 = Cells(iCount, 5) ^ 2
Cells(iCount, 6) = Sqr(carre1 + carre2)

If cnt / 4 = Int(cnt / 4) Then
Cells(iCount, 8) = Cells(iCount, 6) * Cells(iCount - 2, 6)
End If

End If
iCount = iCount + 1
'------ pour les autres touches
Else '--Display the key pressed
Reponse = MsgBox("vous avez pressé : " & _
sKey & " code Ascii=" & Asc(sKey) _
& Chr(10) & _
"Il faut presser <<Enter>> pour mémoriser les coordonnées" _
& Chr(10) & "il faut presser <<Escape>> pour arreter", _
vbExclamation, "GD_DigiPad")
End If
'-------reprise de la scrutation
GoTo encore
Application.StatusBar = False
End Sub
'***************************************************************************
'* FUNCTION NAME: CHECK KEYBOARD BUFFER - 32 BIT *
'* AUTHOR & DATE: STEPHEN BULLEN, 9 APRIL 1996 *
'* DESCRIPTION: This function uses Windows API calls to check if there *
'* are any 'Key down' messages for the application. If *
'* there are some, it returns the key pressed as a string *
'***************************************************************************
Function funCheckKey32() As String
'Dimension variables
Dim msgMessage As MSG32
Dim iHwnd As Long
Dim i As Long
'Dimension Windows API constants
Const WM_CHAR As Long = &H102
Const WM_KEYDOWN As Long = &H100
Const PM_REMOVE As Long = &H1
Const PM_NOYIELD As Long = &H2
'Default to no key pressed
funCheckKey32 = ""
'Get the window handle of this application
iHwnd = FindWindow32("XLMAIN", Application.Caption)
'See if there are any "Key down" messages
i = PeekMessage32(msgMessage, iHwnd, _
WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE + PM_NOYIELD)
'If so ...
If i <> 0 Then
'... translate the virtual key code to a character code ...
i = TranslateMessage32(msgMessage)
'... and get the character code message
i = PeekMessage32(msgMessage, _
iHwnd, WM_CHAR, WM_CHAR, PM_REMOVE + PM_NOYIELD)
'Return the character of the key pressed
funCheckKey32 = Chr(msgMessage.wParam)
End If

End Function

'***************************

--
Amicalement

Jean-François Aubert
{Vaudois de la Côte Lémanique}


"Marc" <nospam-maverick41@caramail.com> a écrit dans le message de
news:094201c34b9c$032fee00$a601280a@phx.gbl...
Bonjours a tous et a toutes
Je cherche à calculer la surface en pixel d'un Shape en VB
sous Excel

Cela fait pas mal de temps que je cherche et je ne trouve
pas...

Par avance merci.
Marc

Pas de challenge pour moi, cet été !
Pour une sélection d'une forme elliptique :

Sub Aire_Intérieure_Ellipse()
Set e = Selection
p = WorksheetFunction.Pi
MsgBox p * e.Height * e.Width / 4
End Sub

Serge


"Modeste" <GeeDee@msixnet.fr> a écrit dans le message de news:
00b401c34bb1$a9269b00$a301280a@phx.gbl...
Bonsoir,
s'il s'agit de la surface occupée par les poignées de
recopie alors :
Shapes("zaza").width *shapes("zaza").height
je n'ai pas vérifié si cela reste vrai en cas de
rotation...

s'il s'agit de la surface coloré du shape :
quelques problemes à identifier :
notament forme du shape :
a - forme simple( triangle, parallélogramme, ellipse)
connaissant les coordonnées quelques formules de
géométrie devrait permettre la solution.
b - forme simple décomposable en figure géometrique
élementaire.
c - forme de révolution.
d - forme aléatoire.

pour le cas b :
il me semble avoir aperçu un programme excel (chez un guru
américain "Tushar Meta" ???) qui faisait ça, je vais
essayer de retrouver.

pour les autres cas, cela peut etre un challenge pour
notre ami Serge "Garnote"

;-)))
@+

-----Message d'origine-----
Bonjours a tous et a toutes
Je cherche à calculer la surface en pixel d'un Shape en
VB

sous Excel

Cela fait pas mal de temps que je cherche et je ne trouve
pas...

Par avance merci.
Marc
.

Et pour une sélection d'une forme cylindrique,
je crois que :

Sub Aire_Totale_Cylindre()
'Aire latérale + aires
'du dessus et du dessous
'd'un cylindre:
Set c = Selection
p = WorksheetFunction.Pi
L = c.Width
H = c.Height
MsgBox p * L * (H + L / 2)
End Sub

Certains calculs d'aires semblent identiques suite à
des rotations de la forme alors que d'autres, non !

Serge


"garnote" <laogarno@globetrotter.net> a écrit dans le message de news:
gshRa.47551$q42.34939@charlie.risq.qc.ca...

Pas de challenge pour moi, cet été !
Pour une sélection d'une forme elliptique :

Sub Aire_Intérieure_Ellipse()
Set e = Selection
p = WorksheetFunction.Pi
MsgBox p * e.Height * e.Width / 4
End Sub

Serge


"Modeste" <GeeDee@msixnet.fr> a écrit dans le message de news:
00b401c34bb1$a9269b00$a301280a@phx.gbl...
Bonsoir,
s'il s'agit de la surface occupée par les poignées de
recopie alors :
Shapes("zaza").width *shapes("zaza").height
je n'ai pas vérifié si cela reste vrai en cas de
rotation...

s'il s'agit de la surface coloré du shape :
quelques problemes à identifier :
notament forme du shape :
a - forme simple( triangle, parallélogramme, ellipse)
connaissant les coordonnées quelques formules de
géométrie devrait permettre la solution.
b - forme simple décomposable en figure géometrique
élementaire.
c - forme de révolution.
d - forme aléatoire.

pour le cas b :
il me semble avoir aperçu un programme excel (chez un guru
américain "Tushar Meta" ???) qui faisait ça, je vais
essayer de retrouver.

pour les autres cas, cela peut etre un challenge pour
notre ami Serge "Garnote"

;-)))
@+

-----Message d'origine-----
Bonjours a tous et a toutes
Je cherche à calculer la surface en pixel d'un Shape en
VB

sous Excel

Cela fait pas mal de temps que je cherche et je ne trouve
pas...

Par avance merci.
Marc
.

Pas de challenge pour moi, cet été !

Ouais, il est vraiment en vacances, notre Serge. Il ne répond guère plus à
ceux qui répondent à tes challenges (i.e. Une Colle VBA) ...

Salutations quand même ;-)

Daniel M.

Où ça ? où ça ?
Mon message est disparu de mon écran.

;-)
Serge

"Daniel.M" <daniel.maher@bigfoot.com> a écrit dans le message de news:
#l2Utx9SDHA.2768@tk2msftngp13.phx.gbl...

Pas de challenge pour moi, cet été !

Ouais, il est vraiment en vacances, notre Serge. Il ne répond guère plus à
ceux qui répondent à tes challenges (i.e. Une Colle VBA) ...

Salutations quand même ;-)

Daniel M.

;-)))
Bien vu Jean-françois !
et Hop !!!!...
récupéré illico-presto, me vient d'autres "modestes" idées ....

Je n'y pensais plus à ce truc,
à part Misange personne ne m'en avait fait d'écho !!!
à l'époque j'avais commencé l'inversion des coordonnées ainsi que la
conversion TWIPS <==> PIXELS
puis je m'étais attelé à la capture de la représentation des continents,
pour tenter de représenter cela sur un graphe en pseudo 3D avec animation
tel que SPHERES.XLS que l'on peut le trouver chez Cinquegrani
http://www.prodomosua.it
encore un projet en stand-by ....

;-)))

@+

"Jean-François Aubert" <àOterjfaubert@bluewin.ch> a écrit dans le message de
news:3f159434_2@news.bluewin.ch...

Bonsoir,
J'ai briocolé la proc du classeur <gd-gidipad> de GeeDee.
Il faut enregistrer les coordonnées des cotes de la surface à mesurer,
selon les règles de la géometrie.
Une surface de formes complexe peut être "découpée" en plusieures parties.
Après chaque partie, faire <Escape>, puis cliquer <Annuler> pour avoir les
surfaces

des différentes parties.

Voici l'aide de GeeDee:

Bonjour voici la tablette à numériser de GeeDee !!!
(modifiée par ajf)
Utilisation :
1- ajouter une feuille
2- inserer une image représentant la courbe ou l'objet
dont on désire récupérer les coordonnées.
3- agrandir cette image à la taille optimum visible de cette fenetre
(pour une meilleure précision).
4- activer la macro SaisieXY par Alt + F8
5- placer successivement le curseur de la souris sur les points à
capturer,

en appuyant à chaque fois sur <<Entrée>>
6- <<Escape>> pour arrêter.
6 bis- <<Annuler>> pour prendre les coordonnées d'une autre surface
Nota :
Les coordonnées saisies s'inscriront en colonnes A et B.
Les coordonnées sont en pixels et proportionnelles aux dimensions de
l'image.

Les coordonnées sont fonction de la résolution d'écran utilisée.
Rappel :
les X demarrent (0) à gauche de l'écran.
les Y démarrent (0) en haut de l'écran.
'*************************
Option Base 1
Option Explicit
Public Pointeur As POINTAPI
Public Reponse
Declare Function GetCursorPos Lib "USER32" (lpPoint _
As POINTAPI) As Long
Declare Function GetSystemMetrics Lib "USER32" _
(ByVal nIndex As Long) As Long

'********************************************************************
'* DECLARE WINDOWS 32-BIT API CALLS *
'********************************************************************
'Type to hold the x and y coordinates of the mouse pointer
Type POINTAPI
x As Long
y As Long
End Type
'Type to hold the Windows message information
Type MSG32
hWnd As Long 'the window handle of the app
message As Long 'the type of message (e.g. keydown, keyup etc)
wParam As Long 'stores the key code
lParam As Long '?
time As Long 'time when message posted
pt As POINTAPI 'coordinate of mouse pointer when messahe posted
End Type
'Find the window handle for this instance of Excel
Declare Function FindWindow32 Lib "USER32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
'Look in the message buffer for a message
Declare Function PeekMessage32 Lib "USER32" _
Alias "PeekMessageA" (lpMsg As MSG32, _
ByVal hWnd As Long, ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
'Translate the message from a virtual key code to a ASCII code
Declare Function TranslateMessage32 Lib "USER32" _
Alias "TranslateMessage" (lpMsg As MSG32) As Long
'********************************************************************
'* Procedure basée sur la fonction *
'* CHECK FOR A KEY PRESS *
'* By Stephen Bullen, Stephen@BMSLtd.co.uk *
'* Modifié par Ajf 16.07.2003 *
'********************************************************************
Sub SaisieXY()
Dim iCount As Integer
Dim sKey As String

Dim cnt As Integer
Dim tbl As Variant
Dim carre1, carre2
ReDim tbl(100, 2)
Application.DisplayStatusBar = True
Application.StatusBar = "Déplacez la souris !!!"
iCount = 2
Reponse = MsgBox("En pressant la touche <<Entrée>>" _
& Chr(10) & _
"les coordonnées apparaissant en bas à gauche seront mémorisées", _
vbInformation, "GD_DigiPad")
'Just loop until a key is pressed
encore:
Application.Cursor = xlNorthwestArrow
Do
GetCursorPos Pointeur
Application.StatusBar = _
"Point N°" & iCount & " X=" & Pointeur.x & " Y=" & Pointeur.y
'Call the appropriate routine to check the keyboard buffer
sKey = funCheckKey32
Loop Until sKey <> ""
'------test si la touche escape à été activée
If sKey = Chr(27) Then
Reponse = MsgBox("Fin de capture ???" & vbLf & vbLf & _
"si vous desirez créer une nouvelle série " & _
"de coordonnées sans écraser les anciennes" & vbLf & _
"cliquez sur <Annuler> ", vbYesNoCancel + vbQuestion, "GD_DigiPad")
If Reponse <> vbNo Then ' ----------c'est vraiment fini
If Reponse = vbYes Then
Application.Cursor = xlDefault
Application.StatusBar = False
Exit Sub
Else '---------bouton <Annuler> pour une nlle série sans écraser

ActiveSheet.Cells(iCount, 1).Value = "X (horizontal)"
ActiveSheet.Cells(iCount, 2).Value = "Y (vertical)"
iCount = iCount + 1
End If

End If
End If
'------test si la touche entree a été activée
If sKey = Chr(13) Then
ActiveSheet.Cells(1, 1).Value = "X (horizontal)"
ActiveSheet.Cells(1, 2).Value = "Y (vertical)"
ActiveSheet.Cells(1, 3).Value = "Coordonnée n° "
ActiveSheet.Cells(1, 4).Value = "amplitude x "
ActiveSheet.Cells(1, 5).Value = "amplitude y "
ActiveSheet.Cells(1, 6).Value = "long. des cotés"
ActiveSheet.Cells(1, 7).Value = ""
ActiveSheet.Cells(1, 8).Value = "aire (pixels) "
cnt = cnt + 1
ActiveSheet.Cells(iCount, 1).Value = Pointeur.x
ActiveSheet.Cells(iCount, 2).Value = Pointeur.y
ActiveSheet.Cells(iCount, 3).Value = cnt
tbl(cnt, 1) = Pointeur.x
tbl(cnt, 2) = Pointeur.y
If cnt / 2 = Int(cnt / 2) Then
Cells(iCount, 4) = Abs(tbl(cnt, 1) - tbl(cnt - 1, 1))
Cells(iCount, 5) = Abs(tbl(cnt, 2) - tbl(cnt - 1, 2))
carre1 = Cells(iCount, 4) ^ 2
carre2 = Cells(iCount, 5) ^ 2
Cells(iCount, 6) = Sqr(carre1 + carre2)

If cnt / 4 = Int(cnt / 4) Then
Cells(iCount, 8) = Cells(iCount, 6) * Cells(iCount - 2, 6)
End If

End If
iCount = iCount + 1
'------ pour les autres touches
Else '--Display the key pressed
Reponse = MsgBox("vous avez pressé : " & _
sKey & " code Ascii=" & Asc(sKey) _
& Chr(10) & _
"Il faut presser <<Enter>> pour mémoriser les coordonnées" _
& Chr(10) & "il faut presser <<Escape>> pour arreter", _
vbExclamation, "GD_DigiPad")
End If
'-------reprise de la scrutation
GoTo encore
Application.StatusBar = False
End Sub

'***************************************************************************

'* FUNCTION NAME: CHECK KEYBOARD BUFFER - 32 BIT *
'* AUTHOR & DATE: STEPHEN BULLEN, 9 APRIL 1996
*

'* DESCRIPTION: This function uses Windows API calls to check if there
*

'* are any 'Key down' messages for the application. If
*

'* there are some, it returns the key pressed as a string
*

'***************************************************************************

Function funCheckKey32() As String
'Dimension variables
Dim msgMessage As MSG32
Dim iHwnd As Long
Dim i As Long
'Dimension Windows API constants
Const WM_CHAR As Long = &H102
Const WM_KEYDOWN As Long = &H100
Const PM_REMOVE As Long = &H1
Const PM_NOYIELD As Long = &H2
'Default to no key pressed
funCheckKey32 = ""
'Get the window handle of this application
iHwnd = FindWindow32("XLMAIN", Application.Caption)
'See if there are any "Key down" messages
i = PeekMessage32(msgMessage, iHwnd, _
WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE + PM_NOYIELD)
'If so ...
If i <> 0 Then
'... translate the virtual key code to a character code ...
i = TranslateMessage32(msgMessage)
'... and get the character code message
i = PeekMessage32(msgMessage, _
iHwnd, WM_CHAR, WM_CHAR, PM_REMOVE + PM_NOYIELD)
'Return the character of the key pressed
funCheckKey32 = Chr(msgMessage.wParam)
End If

End Function

'***************************

--
Amicalement

Jean-François Aubert
{Vaudois de la Côte Lémanique}


"Marc" <nospam-maverick41@caramail.com> a écrit dans le message de
news:094201c34b9c$032fee00$a601280a@phx.gbl...
Bonjours a tous et a toutes
Je cherche à calculer la surface en pixel d'un Shape en VB
sous Excel

Cela fait pas mal de temps que je cherche et je ne trouve
pas...

Par avance merci.
Marc

Salut Modeste,
Eh oui, j'avais bien gardé au chaud ton gidipad, le trouvant très interressant.
--
Amicalement

Jean-François Aubert
{Vaudois de la Côte Lémanique}


"gee-dee-" <gee-dee-@msixnet.fr> a écrit dans le message de
news:%23n7A4O%23SDHA.2852@tk2msftngp13.phx.gbl...

;-)))
Bien vu Jean-françois !
et Hop !!!!...
récupéré illico-presto, me vient d'autres "modestes" idées ....

Je n'y pensais plus à ce truc,
à part Misange personne ne m'en avait fait d'écho !!!
à l'époque j'avais commencé l'inversion des coordonnées ainsi que la
conversion TWIPS <==> PIXELS
puis je m'étais attelé à la capture de la représentation des continents,
pour tenter de représenter cela sur un graphe en pseudo 3D avec animation
tel que SPHERES.XLS que l'on peut le trouver chez Cinquegrani
http://www.prodomosua.it
encore un projet en stand-by ....

;-)))

@+

"Jean-François Aubert" <àOterjfaubert@bluewin.ch> a écrit dans le message de
news:3f159434_2@news.bluewin.ch...

Bonsoir,
J'ai briocolé la proc du classeur <gd-gidipad> de GeeDee.
Il faut enregistrer les coordonnées des cotes de la surface à mesurer,
selon les règles de la géometrie.
Une surface de formes complexe peut être "découpée" en plusieures parties.
Après chaque partie, faire <Escape>, puis cliquer <Annuler> pour avoir les
surfaces

des différentes parties.

Voici l'aide de GeeDee:

Bonjour voici la tablette à numériser de GeeDee !!!
(modifiée par ajf)
Utilisation :
1- ajouter une feuille
2- inserer une image représentant la courbe ou l'objet
dont on désire récupérer les coordonnées.
3- agrandir cette image à la taille optimum visible de cette fenetre
(pour une meilleure précision).
4- activer la macro SaisieXY par Alt + F8
5- placer successivement le curseur de la souris sur les points à
capturer,

en appuyant à chaque fois sur <<Entrée>>
6- <<Escape>> pour arrêter.
6 bis- <<Annuler>> pour prendre les coordonnées d'une autre surface
Nota :
Les coordonnées saisies s'inscriront en colonnes A et B.
Les coordonnées sont en pixels et proportionnelles aux dimensions de
l'image.

Les coordonnées sont fonction de la résolution d'écran utilisée.
Rappel :
les X demarrent (0) à gauche de l'écran.
les Y démarrent (0) en haut de l'écran.
'*************************
Option Base 1
Option Explicit
Public Pointeur As POINTAPI
Public Reponse
Declare Function GetCursorPos Lib "USER32" (lpPoint _
As POINTAPI) As Long
Declare Function GetSystemMetrics Lib "USER32" _
(ByVal nIndex As Long) As Long

'********************************************************************
'* DECLARE WINDOWS 32-BIT API CALLS *
'********************************************************************
'Type to hold the x and y coordinates of the mouse pointer
Type POINTAPI
x As Long
y As Long
End Type
'Type to hold the Windows message information
Type MSG32
hWnd As Long 'the window handle of the app
message As Long 'the type of message (e.g. keydown, keyup etc)
wParam As Long 'stores the key code
lParam As Long '?
time As Long 'time when message posted
pt As POINTAPI 'coordinate of mouse pointer when messahe posted
End Type
'Find the window handle for this instance of Excel
Declare Function FindWindow32 Lib "USER32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
'Look in the message buffer for a message
Declare Function PeekMessage32 Lib "USER32" _
Alias "PeekMessageA" (lpMsg As MSG32, _
ByVal hWnd As Long, ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
'Translate the message from a virtual key code to a ASCII code
Declare Function TranslateMessage32 Lib "USER32" _
Alias "TranslateMessage" (lpMsg As MSG32) As Long
'********************************************************************
'* Procedure basée sur la fonction *
'* CHECK FOR A KEY PRESS *
'* By Stephen Bullen, Stephen@BMSLtd.co.uk *
'* Modifié par Ajf 16.07.2003 *
'********************************************************************
Sub SaisieXY()
Dim iCount As Integer
Dim sKey As String

Dim cnt As Integer
Dim tbl As Variant
Dim carre1, carre2
ReDim tbl(100, 2)
Application.DisplayStatusBar = True
Application.StatusBar = "Déplacez la souris !!!"
iCount = 2
Reponse = MsgBox("En pressant la touche <<Entrée>>" _
& Chr(10) & _
"les coordonnées apparaissant en bas à gauche seront mémorisées", _
vbInformation, "GD_DigiPad")
'Just loop until a key is pressed
encore:
Application.Cursor = xlNorthwestArrow
Do
GetCursorPos Pointeur
Application.StatusBar = _
"Point N°" & iCount & " X=" & Pointeur.x & " Y=" & Pointeur.y
'Call the appropriate routine to check the keyboard buffer
sKey = funCheckKey32
Loop Until sKey <> ""
'------test si la touche escape à été activée
If sKey = Chr(27) Then
Reponse = MsgBox("Fin de capture ???" & vbLf & vbLf & _
"si vous desirez créer une nouvelle série " & _
"de coordonnées sans écraser les anciennes" & vbLf & _
"cliquez sur <Annuler> ", vbYesNoCancel + vbQuestion, "GD_DigiPad")
If Reponse <> vbNo Then ' ----------c'est vraiment fini
If Reponse = vbYes Then
Application.Cursor = xlDefault
Application.StatusBar = False
Exit Sub
Else '---------bouton <Annuler> pour une nlle série sans écraser

ActiveSheet.Cells(iCount, 1).Value = "X (horizontal)"
ActiveSheet.Cells(iCount, 2).Value = "Y (vertical)"
iCount = iCount + 1
End If

End If
End If
'------test si la touche entree a été activée
If sKey = Chr(13) Then
ActiveSheet.Cells(1, 1).Value = "X (horizontal)"
ActiveSheet.Cells(1, 2).Value = "Y (vertical)"
ActiveSheet.Cells(1, 3).Value = "Coordonnée n° "
ActiveSheet.Cells(1, 4).Value = "amplitude x "
ActiveSheet.Cells(1, 5).Value = "amplitude y "
ActiveSheet.Cells(1, 6).Value = "long. des cotés"
ActiveSheet.Cells(1, 7).Value = ""
ActiveSheet.Cells(1, 8).Value = "aire (pixels) "
cnt = cnt + 1
ActiveSheet.Cells(iCount, 1).Value = Pointeur.x
ActiveSheet.Cells(iCount, 2).Value = Pointeur.y
ActiveSheet.Cells(iCount, 3).Value = cnt
tbl(cnt, 1) = Pointeur.x
tbl(cnt, 2) = Pointeur.y
If cnt / 2 = Int(cnt / 2) Then
Cells(iCount, 4) = Abs(tbl(cnt, 1) - tbl(cnt - 1, 1))
Cells(iCount, 5) = Abs(tbl(cnt, 2) - tbl(cnt - 1, 2))
carre1 = Cells(iCount, 4) ^ 2
carre2 = Cells(iCount, 5) ^ 2
Cells(iCount, 6) = Sqr(carre1 + carre2)

If cnt / 4 = Int(cnt / 4) Then
Cells(iCount, 8) = Cells(iCount, 6) * Cells(iCount - 2, 6)
End If

End If
iCount = iCount + 1
'------ pour les autres touches
Else '--Display the key pressed
Reponse = MsgBox("vous avez pressé : " & _
sKey & " code Ascii=" & Asc(sKey) _
& Chr(10) & _
"Il faut presser <<Enter>> pour mémoriser les coordonnées" _
& Chr(10) & "il faut presser <<Escape>> pour arreter", _
vbExclamation, "GD_DigiPad")
End If
'-------reprise de la scrutation
GoTo encore
Application.StatusBar = False
End Sub

'***************************************************************************

'* FUNCTION NAME: CHECK KEYBOARD BUFFER - 32 BIT *
'* AUTHOR & DATE: STEPHEN BULLEN, 9 APRIL 1996
*

'* DESCRIPTION: This function uses Windows API calls to check if there
*

'* are any 'Key down' messages for the application. If
*

'* there are some, it returns the key pressed as a string
*

'***************************************************************************

Function funCheckKey32() As String
'Dimension variables
Dim msgMessage As MSG32
Dim iHwnd As Long
Dim i As Long
'Dimension Windows API constants
Const WM_CHAR As Long = &H102
Const WM_KEYDOWN As Long = &H100
Const PM_REMOVE As Long = &H1
Const PM_NOYIELD As Long = &H2
'Default to no key pressed
funCheckKey32 = ""
'Get the window handle of this application
iHwnd = FindWindow32("XLMAIN", Application.Caption)
'See if there are any "Key down" messages
i = PeekMessage32(msgMessage, iHwnd, _
WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE + PM_NOYIELD)
'If so ...
If i <> 0 Then
'... translate the virtual key code to a character code ...
i = TranslateMessage32(msgMessage)
'... and get the character code message
i = PeekMessage32(msgMessage, _
iHwnd, WM_CHAR, WM_CHAR, PM_REMOVE + PM_NOYIELD)
'Return the character of the key pressed
funCheckKey32 = Chr(msgMessage.wParam)
End If

End Function

'***************************

--
Amicalement

Jean-François Aubert
{Vaudois de la Côte Lémanique}


"Marc" <nospam-maverick41@caramail.com> a écrit dans le message de
news:094201c34b9c$032fee00$a601280a@phx.gbl...
Bonjours a tous et a toutes
Je cherche à calculer la surface en pixel d'un Shape en VB
sous Excel

Cela fait pas mal de temps que je cherche et je ne trouve
pas...

Par avance merci.
Marc

J'ai retrouvé ma solution qui donne bien 4 562 :

Sub Changer_100()
Dim n As Integer, s As Integer
For n = 0 To 10
s = s + Round((10 * n + 4) ^ 2 / 20) * Round((14 - n) ^ 2 / 20)
Next n
MsgBox Format(s, "#,##0")
End Sub

Serge


"gee-dee-" <gee-dee-@msixnet.fr> a écrit dans le message de news:
#jyBDo#SDHA.1920@TK2MSFTNGP11.phx.gbl...

Bonsoir Serge
la réponse est 4562 façons différentes
(il me semble que la solution avait été donnée trés rapidement, malgré
l'énoncé erroné de 500$ )
;-)))) moi j'avais éxplosé ma feuille de calcul .

mais si l'on oblige l'utilisation d'au moins un billet ou pièce de chaque
valeur
le nombre de façon chute à : 15
@+

"garnote" <laogarno@globetrotter.net> a écrit dans le message de
news:GWjRa.47566$q42.37191@charlie.risq.qc.ca...

Non seulement je n'ai pas répondu, (maudites vacances !)
mais il fallait lire :
De combien de façons différentes peut-on obtenir
100$ (et non pas 500$) en utilisant des billets
de 5$, 10$, 20$, et 50$ et des pièces de 1$ et 2$ ?

Serge


"Daniel.M" <daniel.maher@bigfoot.com> a écrit dans le message de news:
#l2Utx9SDHA.2768@tk2msftngp13.phx.gbl...

Pas de challenge pour moi, cet été !

Ouais, il est vraiment en vacances, notre Serge. Il ne répond guère
plus

à

ceux qui répondent à tes challenges (i.e. Une Colle VBA) ...

Salutations quand même ;-)

Daniel M.