Ecriture dans cellules discontinues

Question

Dans un classeur avec 2 feuilles, je doit saisie un paragraphe en cellule B7 de la Feuil1. Dés que cette cellule est remplie, j'aimerai que la suite s'écrive en cellule B7 de la Feuil2 automatiquement. Est-il possible de faire ce genre de saisie, et si oui, est-il possible de m'orienter ? Par avance, merci...

EngueEngue · Answer

Définit cellule remplie Utilise la fonction =rept("a";1500) et =rept("A";1500), une majuscule ne prend pas la même place qu'une minuscule, tu ne peux donc pas le faire automatiquement...

EngueEngue · Answer

Je crois que tu n'as pas compris... Il n'est pas possible de détecter quand une cellule est trop petite pour l'affichage.

Le seul moyen de faire cela est de compter le nombre de caractères, mais le nombre de caractères pour une place donnée est différent.

10 A prennent plus de place que 10 a

AAAAAAAAAA

aaaaaaaaaa

Comprends-tu ?

EngueEngue · Answer

Après quelques prises de têtes, voilà ce que je te propose:

Vire les PtrSafe si tu es sur du 32 bits:

Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long
Private Declare PtrSafe Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long

Private Const LOGPIXELSY As Long = 90

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

Private Type SIZE
    cx As Long
    cy As Long
End Type
Public Function getLabelPixel(label As String) As Integer

  Dim font As New StdFont
  Dim sz As SIZE
  font.Name = "Calibri"
  font.SIZE = 11

  sz = GetLabelSize(label, font)
  getLabelPixel = sz.cx

End Function

Private Function GetLabelSize(text As String, font As StdFont) As SIZE
    Dim tempDC As Long
    Dim tempBMP As Long
    Dim f As Long
    Dim lf As LOGFONT
    Dim textSize As SIZE

    ' Create a device context and a bitmap that can be used to store a
    ' temporary font object
    tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
    tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)

    ' Assign the bitmap to the device context
    DeleteObject SelectObject(tempDC, tempBMP)

    ' Set up the LOGFONT structure and create the font
    lf.lfFaceName = font.Name & Chr$(0)
    lf.lfHeight = -MulDiv(font.SIZE, GetDeviceCaps(GetDC(0), 90), 72) 'LOGPIXELSY
    lf.lfItalic = font.Italic
    lf.lfStrikeOut = font.Strikethrough
    lf.lfUnderline = font.Underline
    If font.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400
    f = CreateFontIndirect(lf)

    ' Assign the font to the device context
    DeleteObject SelectObject(tempDC, f)

    ' Measure the text, and return it into the textSize SIZE structure
    GetTextExtentPoint32 tempDC, text, Len(text), textSize

    ' Clean up (very important to avoid memory leaks!)
    DeleteObject f
    DeleteObject tempBMP
    DeleteDC tempDC
  ' Return the measurements
    GetLabelSize = textSize

End Function

Sub toto()
x = getLabelPixel(Range("A1").Value)
MsgBox (x)
End Sub

Le sub toto va te donner la longueur en pixels réels de ton string. Tu pourras donc évaluer la longueur maximale de ta cellule et couper là ou il faut.

Bon courage.

Banzai64 · Answer

J'ai réfléchi un petit peu plus Déjà si c'est en cours de frappe, je ne sais pas (je pense impossible à faire dans une cellule) Sinon une idée qui en vaut une autre Une fois ton commentaire écrit, le découper en laissant dans la 1ère cellule les 2-3 premiers mots et le reste dans l'autre cellule On ajuste la largeur de la cellule à ces mots Pas trop à chercher si c'est facile à faire C'est cette affirmation qui me bloque Comment le sais tu ...

EngueEngue · Answer

On peut mesurer la largueur de la cellule, la hauteur. Si la taille du texte et la police sont constantes on peut trouver à partir de quel pixel on dépasse avec un while en bouclant. Puis couper et continuer...

Banzai64 · Answer

Cela va être très compliqué Car là tu penses une fois le texte écrit Quid de la correction de ce texte , même la simple lecture de tout ce texte Juste un essai, suivant mon idée, mais même comme cela cela devient compliqué, et je ne crois pas que j'irais plus loin...

EngueEngue · Answer

Avec ma méthode, valable pour du x64 il faut virer les ptrsafe pour les x32...