Transformer une zone de texte en image jpg

Le 30/04/2021 à 17:51

Bonjour,

J'ai ce code qui me permet de créer une zone de texte

  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 30, 30, 55, 30).Select
    Selection.Name = "Ma_zone"
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 27
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    Selection.Characters.Text = Range("F1").Text

    With Selection.Characters(Start:=1, Length:=26).Font
        .Name = "Arial"
        .FontStyle = "Normal"
        .Size = 14
        .Bold = True
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 3
    End With

Je n'arrive pas à centrer le texte mais ce n'est pas bien grave

Je voudrais à la suite de code transformer cette zone de texte en image jpg

est-ce possible svp?

Je vous remercie

Cordialement

Le 01/05/2021 à 00:02

Bonsoir Sylvainpyc,

Rajouter en fin de macro après le End With de ta macro

les lignes ci-dessous.

Note: la cellule B4 (ou tout autre cellule choisie) doit être à la taille de la zone de texte.

  'Positionne la zone de texte sur la cellule de copie. Pour l'exemple en B4
    Selection.Top = Range("B24").Top
    Selection.Left = Range("B24").Left
    Call ZoneImage
End Sub

Et Ajouter cette nouvelle macro

Sub ZoneImage()
'Caractèristiques
  Dim objChrt As Chart
  Dim rngImage As Range
  Dim strFile As String
'Gestion erreur
  On Error GoTo ErrExit
'Nom de la feuille (à modifier, ici pour exemple) ou se trouve la zone de texte
  With Sheets("Resultats")
'Choisir la cellule ou est positionnée la zone de texte selon fin de 1ière macro
    Set rngImage = .Range("B24")
'puis copie de la cellule contenant la zone de texte
    rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
'Sous le dossier Images du disque C, Ici le dossier Images. Sinon changer par le chemin (Disque, dossier et sous-dossier) souhaité
    strFile = "C:\Users\X Cellus\Pictures\CopieNote.jpg"
'Selon taille de la zone de texte
    Set objChrt = .ChartObjects.Add(rngImage.Left, rngImage.Top, rngImage.Width, rngImage.Height).Chart
    'Réalise l'export avec l'objet Chart
    With objChrt
        .Parent.Activate
        .ChartArea.Format.Line.Visible = msoFalse 'Ligne du cadre non visible
        .Paste
        .Export strFile
        .Parent.Delete
    End With

  End With
'Libère les objets
ErrExit:
  Set objChrt = Nothing
  Set rngImage = Nothing
End Sub

L'image CopieNote au format jpg sera visible dans le répertoire Images.

Le 01/05/2021 à 08:56

C'est super

Merci

Est-il possible svp de centrer le texte dans la zone de texte ?

Je vous remercie

Le 01/05/2021 à 09:25

Bonjour,

As-tu essayé de voir avec l'enregistreur de macro ce que cela donne ?

Ca ne paraît pas être une tâche insurmontable et c'est un bon exercice pour progresser

Le 01/05/2021 à 09:39

Bonjour,

J'ai essayé avec l'enregistreur mais je n'arrive pas à adapter le code obtenu à mon code ???

Je vais réessayer

Merci

Le 01/05/2021 à 09:42

n'hésite pas à poster le code obtenu ;)

Le 01/05/2021 à 10:20

Voici mon code

Sub Ellipse3_Cliquer()
Dim t1 As Integer
Dim H%, HH, Mn As String
Dim s As Integer

Phrase = Range("a2").Value
Phrase = Replace(Phrase, " ", "00", 1): H = InStr(1, Phrase, "h") - 1
If IsNumeric(H) Then HH = Replace(Trim(Mid(" " & Phrase, H, 5)), "h", ":"): Mn = Right(HH, 2)
HH = Left(CStr(TimeValue(HH)), 5 + (Mn = "00") * 2)
HH = Replace(HH, ":", "h")
If Left(HH, 1) = 0 Then
HH = Right(HH, Len(HH) - 1)
End If
Select Case Len(HH)
    Case Is = 5
        t1 = 55
    Case Is = 4
        t1 = 50
    Case Is = 3
        t1 = 100
    Case Is = 2
        t1 = 35
End Select
 ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 30, 30, t1, 30).Select
    Selection.Name = "Ma_zone"
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 27
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    Selection.Characters.Text = HH

    With Selection.Characters(Start:=1, Length:=26).Font
        .Name = "Arial"
        .FontStyle = "Normal"
        .Size = 14
        .Bold = True
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 3
    End With
    ActiveSheet.Shapes.Range(Array("Ma_zone")).Select
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
        msoAlignCenter

  'Positionne la zone de texte sur la cellule de copie. Pour l'exemple en B4
    Selection.Top = Range("B24").Top
    Selection.Left = Range("B24").Left
    Call ZoneImage
End Sub

J'ai rajouté en fin de code le résultat obtenu avec l'enregistreur de macro

ActiveSheet.Shapes.Range(Array("Ma_zone")).Select
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
        msoAlignCenter

Ca ne bug pas mais ca ne centre pas non plus

Le 01/05/2021 à 10:36

Supprime ce que tu as rajouté et ne garde que la ligne :

    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter

Et tu la colles au milieu des autres lignes qui commencent par Selection.shaperange.....
Et ça fonctionne.

Je n'ai pas suivi, mais le code proposé par X cellus ne convient pas mieux que le tien ?

Edit : Oh, ce n'était qu'un complément. Le code proposé par Algoplus est mieux que ce qui a été généré par l'enregistreur de macro. Mais ça veut dire qu'il faut l'intégrer dans un nouveau with ... end with. Mais c'est comme ça qu'on progresse ;)

Le 01/05/2021 à 10:41

Bonjour à tous,

essayer:

With ActiveSheet.Shapes("Ma_zone").TextFrame
 .HorizontalAlignment = xlCenter
 .VerticalAlignment = xlCenter
End With

A+

Le 01/05/2021 à 11:05

Merci beaucoup

Ca fonctionne parfaitement, votre aide m'ait précieuse. Merci

Il ne me reste plus qu'à régler le début du code concernant la recherche d'une heure dans une chaine de caractère que j'ai exposé dans un autre sujet "Récupérer heure dans une chaîne de caractère d'une variable"

Merci encore à tous de votre aide

Cordialement

Rechercher des sujets similaires à "transformer zone texte image jpg"