Autres générer un nom de fichier image qui n'existe pas dans le dossier

[patricktoulon]

bonjour a tous
je voudrais modifier ma fonction qui me genere un nom de fichier
en effet
je sélectionne une image avec un dialog et je fait un copyfile vers un autre dossier sous le nom de (image1 , image2 ,image3,etc.....)avec son extension
ce nom je l'obtiens grace a une fonction que j'ai bien mal pensé car en effet il m'arrive de changer d'avis et de supprimer une image (l'incrémentation n'est donc plus valable dans ce contexte)

sub test
 fic = Application.GetOpenFilename("image Files (*.png;*.ico;*.bmp;*.jpg), *.png;*.ico;*.bmp;*.jpg", 1, "choisir un fichier")
    If fic = False Then Exit Sub
   ' btxdelattributimagemso_Click
    NomFichier = newNameImage(fic)
    'dossier = Mid(tbxfichtxt, 1, InStrRev(tbxfichtxt, "\") - 1)
    FileCopy fic, dossierimage & "\" & NomFichier
End sub

Function newNameImage(fic)
    Dim itemVu, q&
    itemVu = Dir(dossierimage & "\*.*")
    If itemVu = "" Then
        q = 0
    Else
        Do While itemVu <> "": q = q + 1: itemVu = Dir: Loop
    End If
    newNameImage = "Image" & q & Mid(fic, InStrRev(fic, "."))
End Function

des idées?

 

[patricktoulon]

re
bon n fait c'etait tellement simple que ca m'est passé au dessus de la tète

Function newNameImage(fic)
    Dim q&
    Do While Dir(dossierimage & "\Image" & q & ".*") <> "": q = q + 1: Loop
        newNameImage = "Image" & q & Mid(fic, InStrRev(fic, "."))
End Function

 

[soan]

Bonjour patrick,

j'suis toujours drôlement surpris quand j'vois un sujet de toi, car pour moi, t'es un as des as qui sait tout faire ! (si, si, vraiment, j't'assure ! ) ; comme j'l'avais déjà écrit une fois, j'adore les exos qui s'résolvent tout seuls : j'ai rien eu à faire du tout, puisque t'as réussi à solutionner ton problème avant qu'un autre intervenant t'apporte une solution !
​

soan

 

[patricktoulon]

oui bonjour Soan
c'est souvent le cas je plante sur des trucs simples (mais pas longtemps)

un As je pense pas ,j'ai un peu de bouteille c'est tout

là en ce moment je plante sur beaucoup plus complexe a mettre en oeuvre

 

[soan]

alors j'te souhaite bonne chance pour trouver une autre solution,
et pour la suite de ton projet actuel. ​

soan

 

[patricktoulon]

il est casiment abouti je cale sur un repaint partiel
comme tu peux le voir sur cette capture quand j'ajoute un element le repaint prend un certain temps
quand le visuel est fourni
je cherche donc une solution pour remplacer ma sub visual qui refait la frame totalement pour une solution qui m'ajouterais mon element en faisant un repaint uniquement a partir du parent de l’élément ajouté
c'est pas simple vu que le positionnement est incrémenté par la boucle elle même

'***************************************************** fonction raffraichissement du visuel du visuel **********************************

Sub visual()    ' raffraichissement du visual
    Dim ctrl, All, T&, elem, X&, L&, B, q&, nom$, nomparent$, w, wx
    For Each ctrl In Frame1.Controls
        Me.Controls.Remove ctrl.Name
    Next
    Set All = docXML.getelementsbytagname("*")
    T = 5
    For Each elem In All
        With Me.Frame1
            X = X + 1
            nom = IIf(IsNull(elem.getattribute("id")), elem.tagname, elem.getattribute("id"))
            Set B = .Controls.Add("Forms.Label.1", nom, True)
            If elem.getattribute("onLoad") <> "" Then tbxRibbonOnLoad = elem.getattribute("onLoad")
            L = 0
            If X >= 2 Then
                nomparent = IIf(IsNull(elem.ParentNode.getattribute("id")), elem.ParentNode.tagname, elem.ParentNode.getattribute("id"))
                'MsgBox nom & vbCrLf & nomparent
                L = .Controls(nomparent).Left + 20
            End If
            With B
                If elem.tagname = "group" Then T = T + 10: w = 120 Else w = 120:
                .Move L, T, w, 17:
              
                .Caption = IIf(IsNull(elem.getattribute("label")), "    " & elem.tagname, "    " & elem.getattribute("label"))
                If elem.tagname = "separator" Then .Caption = "separator"
                .BorderStyle = 1
                .PicturePosition = 0
                If Not IsNull(elem.getattribute("imageMso")) Then B.Picture = Application.CommandBars.GetImageMso(elem.getattribute("imageMso"), 25, 25)
                .TextAlign = 1
                .ControlTipText = "--" & UCase(elem.tagname) & "--" & elem.getattribute("label")
            End With
            If elem.tagname <> "ribbon" And elem.tagname <> "customUI" Then
                q = q + 1: ReDim Preserve cls(1 To q): Set cls(q).BtX = B
            End If
            Select Case elem.tagname
            Case "ribbon": B.BackColor = RGB(220, 220, 220)
            Case "tabs": B.BackColor = RGB(200, 200, 200)
            Case "tab": B.BackColor = RGB(180, 180, 180)
            Case "group": B.BackColor = RGB(255, 150, 150)
            Case "box": B.BackColor = IIf(elem.getattribute("boxStyle") = "vertical", RGB(255, 255, 150), RGB(150, 255, 255))
            Case "button": B.BackColor = RGB(0, 190, 255)
            Case "gallery": B.BackColor = RGB(255, 255, 150)
            Case "dynamicMenu": B.BackColor = RGB(0, 255, 0)
            Case "menu": B.BackColor = RGB(100, 255, 100)
            Case "comboBox": B.BackColor = RGB(255, 0, 190)
            Case "editBox": B.BackColor = RGB(240, 240, 240)
            Case "dropDown": B.BackColor = RGB(235, 0, 190)
            Case "buttonGroup": B.BackColor = RGB(0, 0, 100): B.ForeColor = vbWhite
            Case "toggleButton": B.BackColor = RGB(100, 0, 100): B.ForeColor = vbWhite
            Case "splitButton": B.BackColor = RGB(0, 120, 150): B.ForeColor = vbWhite

            End Select
            T = T + 18
        End With
        If elem.getattribute("image") <> "" Then
            B.Picture = LoadPicture(getcopyWMF(dossierimage & "\" & Dir(dossierimage & "\" & elem.getattribute("image") & ".*")))
        End If
        wx = IIf(B.Width + B.Left > wx, B.Width + B.Left, wx)
     Next
    Me.Repaint
   Frame1.ScrollHeight = Frame1.Controls(Frame1.Controls.Count - 1).Top + 30
    Frame1.ScrollTop = Frame1.ScrollHeight
    Frame1.ScrollWidth = wx
End Sub

 

[soan]

euh... pour éviter ça, moi j'connais que :

Application.ScreenUpdating = False

mais j'suis sûr que tu connais déjà !

... et ça marche pas, pour ton Repaint ?

---

le plus drôle, ça s'rait qu'tu m'répondes que c'est
LA bonne solution !!!

soan

 

[patricktoulon]

re
ben non bien évidement
je vais encore perdre la journée la dessus pour trouver ma solution