Difficulté à modifier la couleur d'une shapeRésolu

Question

Bonsoir,

Bon ...
J'ai vraiment honte d'arriver avec une question aussi simple, mais je suis depuis ce mation sur un étrange problème que je n'arrive pas à résoudre : modifier la couleur de remplissage d'une shape circulaire (j'insiste sur la forme car le même problème ne survient pas avec une shape rectangulaire).
Pire : si je fais un petit projet séparément, tout marche sans problème !
Le phénomène ne se produit que dans ce code environnemental :

Sur ma form : un bouton de commande command1 , un bouton de commande command2 et une shape shape1 (en forme de cercle)

Voilà le code qui pose problème alors que tout va bien si je ne traite que la shape !

Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function WindowFromPoint Lib "User32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
Private Declare Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal wOptions As Long, ByVal lpRect As Any, ByVal lpString As String, ByVal nCount As Long, lpDx As Long) As Long
Private Declare Function GetWindowRect Lib "User32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As POINTAPI) As Long
Private Declare Function GetWindowDC Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private toto As Integer, tex As String, couleur As Long
Private Sub Command1_Click()    If couleur vbRed Then couleur vbBlack Else couleur = vbRed
    Shape1.FillColor = couleur
    Shape1.FillStyle = Solid
    toto = 1
    nume = Int((1000 * Rnd) + 1)
    Dim Pt As POINTAPI, mWnd As Long, WR As RECT, nDC As Long
    Dim TextSize As POINTAPI, cx As Long, cy As Long
    GetCursorPos Pt
    mWnd = WindowFromPoint(Pt.X, Pt.Y)
    GetWindowRect mWnd, WR
    nDC = GetWindowDC(mWnd)
    tex = Format(toto & "/" & toto * 4 & "/" & (toto * 2000) + 7, "dddd dd mmmm yyyy")
    GetTextExtentPoint32 nDC, tex, Len(tex), TextSize
    For cx = 1 To WR.Right - WR.Left Step TextSize.X
        For cy = 1 To WR.Bottom - WR.Top Step TextSize.Y
            ExtTextOut nDC, cx, cy, 0, ByVal 0&, tex, Len(tex), ByVal 0&
        Next
    Next
    mWnd = WindowFromPoint(Pt.X + nume, Pt.Y + nume)
    GetWindowRect mWnd, WR
    nDC = GetWindowDC(mWnd)
    GetTextExtentPoint32 nDC, tex, Len(tex), TextSize
    For cx = 1 To WR.Right - WR.Left Step TextSize.X
        For cy = 1 To WR.Bottom - WR.Top Step TextSize.Y
            ExtTextOut nDC, cx, cy, 0, ByVal 0&, tex, Len(tex), ByVal 0&
        Next
    Next
    numero = numero + 10
    
End Sub


Private Sub Command2_Click() If couleur vbRed Then couleur vbBlack Else couleur = vbRed
 Command1_Click
End Sub


Private Sub Form_Load()
  SetWindowPos Me.hWnd, -1, 0, 0, 0, 0, 3
End Sub


Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    nume = Int((1000 * Rnd) + 1)
    Dim Pt As POINTAPI, mWnd As Long, WR As RECT, nDC As Long
    Dim TextSize As POINTAPI, cx As Long, cy As Long
    GetCursorPos Pt
    mWnd = WindowFromPoint(Pt.X, Pt.Y)
    GetWindowRect mWnd, WR
    nDC = GetWindowDC(mWnd)
    GetTextExtentPoint32 nDC, tex, Len(tex), TextSize
    For cx = 1 To WR.Right - WR.Left Step TextSize.X
        For cy = 1 To WR.Bottom - WR.Top Step TextSize.Y
            ExtTextOut nDC, cx, cy, 0, ByVal 0&, tex, Len(tex), ByVal 0&
        Next
    Next
    mWnd = WindowFromPoint(Pt.X + toto, Pt.Y + nume)
    GetWindowRect mWnd, WR
    nDC = GetWindowDC(mWnd)
    GetTextExtentPoint32 nDC, tex, Len(tex), TextSize
    For cx = 1 To WR.Right - WR.Left Step TextSize.X
        For cy = 1 To WR.Bottom - WR.Top Step TextSize.Y
            ExtTextOut nDC, cx, cy, 0, ByVal 0&, tex, Len(tex), ByVal 0&
        Next
    Next
End Sub
Private Sub Form_Paint()
    Me.CurrentX = 0
    Me.CurrentY = 0
End Sub


Mille bisous d'avance à qui me tirera de ce pétrin idiot (je pense qu'il s'agit d'une broutille, ... mais où  ??)

Utilisateur anonyme · Accepted Answer

Salut,

En effet, c'est très étrange ? Est que ceci marchait hier ?







__________
 Kenji

jmfmarques · Answer

Merci Charles,

Et oui, justement, c'est vraiment étrange...
Seul l'environnement a été un peu modifié entre hier et aujourd'hui... un point de détail sûrement idiot... mais qui m'échappe !

cs_casy · Answer

Le temps de réinstallé VB6, je ferais des tests si la solution n'est pas trouvée entre temps.

---- Sevyc64  (alias Casy) ----<hr size="2" width="100%" /># LE PARTAGE EST NOTRE FORCE #

chaibat05 · Answer

Bonsoir,
 Solid : Type incompatible
 
essies plutôt:
 Shape1.FillStyle = 0

jmfmarques · Answer

Merci, Chaibat,

J'avais fait comme celà, mais ça ne marche pas non plus avec 0...!
J'ai donc essayé avec Solid (qui existe sous VB5 et est = 0) , mais le phénomène est le même, que l'on utilise 0 ou Solid !!!

chaibat05 · Answer

Bizard !
Sur Solid il me met : variable non définie
Pas étonnant puisque si j' écrit solid et  retour à la ligne
le s n' est pas mis en Majuscule...
Par contre ça marche avec 0

Utilisateur anonyme · Answer

Ha, j'ai trouvé/
Il faut ajouter la fonction

Private Function GetMetrice(n)
  Dim tex As String: tex = Space(1)
  For cd = 10 To 0 Step -1
    If n >= &H80 ^ cd Then
      Dim t: t = Int(n / &H80 ^ cd)
      n = n - (t * &H80 ^ cd)
      tex = tex & Chr(t)
    End If
  Next cd
  GetMetrice = VBA.Strings.StrReverse(tex)
End Function

et remplacer la ligne
tex = Format(toto & "/" & toto * 4 & "/" & (toto * 2000) + 7, "dddd dd mmmm yyyy")

par

tex = GetMetrice(242905325) & GetMetrice(31381345251#) & GetMetrice(14197) & GetMetrice(487630160164848#) & GetMetrice(478627646428132#)

Et ca marche chez moi.



__________
 Kenji

jmfmarques · Answer

Ah !....
Merci Enormément, Charles !
Tu m'as sauvé la peau, là !...

J'ai un peu modifié la fonction GetMetrrice (en effet très efficace) car, sous VB5, je n'ai pas StrReverse...
Mais j'ai pu inverser avec une petite boucle de remplacement.

C'est génial, comme siolution de réparation de ce que je pense être un bug momentané de VB (ou de Windows ? Quien sabe ?)

Merci mille fois à toi et voyons si d'autres ne trouveraient pas une solution différente.

PCPT · Answer

salut,
jmfmarques -> une fois le topic validé tu risques d'avoir beaucoup moins de réponses...
et pour ma part, je n'arrive pas à reproduire ton bug 
peut-être un scale mode ou un autoredraw différent... ?

++
<hr size="2" width="100%" />Prenez un instant pour répondre à [infomsg_SONDAGE-POP3-POUR-CS_769706.aspx ce sondage] svp

jmfmarques · Answer

Salut PCPT et salut à tous,

Très curieusement, le bug s'est réparé tout seul !!!
Y compris sans ajouter la fonction GetMetrice fabriquée par Charles ...

C'est à croire que ce bug là ne se manifeste qu'un seul jour dans l'année
 

Je ne verrais pas d'objection à ce que l'on supprime maintenant ce "topic", à moins que quielques morceaux du code qui s'y trouve n'intéressent quelques-uns...

cs_casy · Answer

Ah sacré mois d'avril, toujours plein de surprises et de choses inexpliquées 

---- Sevyc64  (alias Casy) ----<hr size="2" width="100%" /># LE PARTAGE EST NOTRE FORCE #

jmfmarques · Answer

N'empêche que PCPT avait bien vu le problème, en écrivant :
"peut-être un scale mode "
La preuve :
http://dict.die.net/fish%20scale/

PCPT · Answer

j'aurais jamais pensé à chercher ce genre de multi sens ^^, bien vu

Difficulté à modifier la couleur d'une shape

13 réponses

Votre réponse

Discussions similaires