integrazione access word - ridurre immagini

[Akery]

buongiorno,

con il seguente script inserisco delle immagini in due tabelle di un
documento, tuttavia altune immagini hanno dimensioni spropositate e
vorrei ridurle ad un quadrato di lato massimo 2.5cm. Ho gia provato ad
estrarre in codice da word ma non ha funzionato, il vba word restituisce
solo moveup o movedown per la selezione della immagine. Suggerimenti?

Dim Wrd As Word.Application
Dim Doc As Word.Document
Dim tbl As Word.Table

Dim pic, tipo As String


GetDBPath = CurrentProject.Path 'nome percorso


CreateObject ("Word.Application")
On Error Resume Next 'gestione errori step by step 'cerca un'istanza di
Word già aperta
Set Wrd = GetObject(, "Word.Application")
If Err.Number = 429 Then 'se c'è stato un errore è perchè Word non era
già aperto: 'aprilo adesso
Set Wrd = CreateObject("Word.Application")
End If
On Error GoTo 0 'ripristina la segnalazione degli errori

Wrd.Visible = True
Wrd.Activate

Set Doc = Wrd.Documents.Add(CurrentProject.Path &
"/ripre.mod.seges.docx") 'nuovo doc

....
Doc.Bookmarks("n_ambiente").Select
Wrd.Selection.TypeText Me.SIT
....

' da questo punto inserisco le immagini

Me![segnaleticaLAB].SetFocus
DoCmd.GoToRecord , , acFirst

i = 0 'contatore obblighi
j = 0 'contatore avvertimenti e divieti

Do While IsNull(Forms!gestione_locale![segnaleticaLAB]!tipo) = False

tipo = Forms!gestione_locale![segnaleticaLAB]!tipo

If tipo = "obbligo" Then

pic = DLookup("[indirizzo file]", "seges", "[nome segnale]=""" &
Me![segnaleticaLAB]![segnale] & """")

If j < 6 Then
ActiveDocument.Shapes("Rettangolo arrotondato 82").Select
With Selection.Tables(1)
.Cell(1, j + 1).Select
End With
Wrd.Selection.TypeText " "
Wrd.Selection.InlineShapes.AddPicture pic

Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale

j = j + 1
ElseIf j >= 6 Then
MsgBox "hai raggiunto il massimo numero di obblighi!"
End If

Else

pic = DLookup("[indirizzo file]", "seges", "[nome segnale]=""" &
Me![segnaleticaLAB]!segnale & """")

If i < 6 Then
ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
With Selection.Tables(1)
.Cell(1, i + 1).Select
End With
Wrd.Selection.TypeText " "
Wrd.Selection.InlineShapes.AddPicture pic

Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale

i = i + 1

ElseIf i >= 6 And i < 12 Then
ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
With Selection.Tables(1)
.Cell(2, i - 5).Select
End With
Wrd.Selection.TypeText " "
Wrd.Selection.InlineShapes.AddPicture pic

Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale

i = i + 1
ElseIf i >= 12 And i < 18 Then
ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
With Selection.Tables(1)
.Cell(3, i - 11).Select
End With
Wrd.Selection.TypeText " "
Wrd.Selection.InlineShapes.AddPicture pic

Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
i = i + 1

End If


End If

DoCmd.GoToRecord , , acNext

Loop

'Error 11

new_modello = GetDBPath & "\segnaletica\" & Me.COEDI & " - " & Me.SIT &
" - " & Me.Laboratorio & ".docx"
ActiveDocument.SaveAs2 (new_modello)

'Doc.Close

Set Doc = Nothing
Set Wrd = Nothing
'Wrd.Quit


grazie

[BFS]

Post by Akery
buongiorno,
con il seguente script inserisco delle immagini in due tabelle di un
documento, tuttavia altune immagini hanno dimensioni spropositate e
vorrei ridurle ad un quadrato di lato massimo 2.5cm. Ho gia provato ad
estrarre in codice da word ma non ha funzionato, il vba word restituisce
solo moveup o movedown per la selezione della immagine. Suggerimenti?
Dim Wrd As Word.Application
Dim Doc As Word.Document
Dim tbl As Word.Table
Dim pic, tipo As String
GetDBPath = CurrentProject.Path 'nome percorso
CreateObject ("Word.Application")
On Error Resume Next 'gestione errori step by step 'cerca un'istanza di
Word già aperta
Set Wrd = GetObject(, "Word.Application")
If Err.Number = 429 Then 'se c'è stato un errore è perchè Word non era
già aperto: 'aprilo adesso
Set Wrd = CreateObject("Word.Application")
End If
On Error GoTo 0 'ripristina la segnalazione degli errori
Wrd.Visible = True
Wrd.Activate
Set Doc = Wrd.Documents.Add(CurrentProject.Path &
"/ripre.mod.seges.docx")  'nuovo doc
....
Doc.Bookmarks("n_ambiente").Select
Wrd.Selection.TypeText Me.SIT
....
' da questo punto inserisco le immagini
Me![segnaleticaLAB].SetFocus
DoCmd.GoToRecord , , acFirst
i = 0 'contatore obblighi
j = 0 'contatore avvertimenti e divieti
Do While IsNull(Forms!gestione_locale![segnaleticaLAB]!tipo) = False
tipo = Forms!gestione_locale![segnaleticaLAB]!tipo
If tipo = "obbligo" Then
    pic = DLookup("[indirizzo file]", "seges", "[nome segnale]=""" &
Me![segnaleticaLAB]![segnale] & """")
    If j < 6 Then
    ActiveDocument.Shapes("Rettangolo arrotondato 82").Select
    With Selection.Tables(1)
       .Cell(1, j + 1).Select
    End With
    Wrd.Selection.TypeText " "
    Wrd.Selection.InlineShapes.AddPicture pic
    Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
    j = j + 1
    ElseIf j >= 6 Then
    MsgBox "hai raggiunto il massimo numero di obblighi!"
    End If
Else
    pic = DLookup("[indirizzo file]", "seges", "[nome segnale]=""" &
Me![segnaleticaLAB]!segnale & """")
    If i < 6 Then
    ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
    With Selection.Tables(1)
       .Cell(1, i + 1).Select
    End With
    Wrd.Selection.TypeText " "
    Wrd.Selection.InlineShapes.AddPicture pic
    Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
    i = i + 1
    ElseIf i >= 6 And i < 12 Then
    ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
    With Selection.Tables(1)
       .Cell(2, i - 5).Select
    End With
    Wrd.Selection.TypeText " "
    Wrd.Selection.InlineShapes.AddPicture pic
    Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
    i = i + 1
    ElseIf i >= 12 And i < 18 Then
    ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
    With Selection.Tables(1)
       .Cell(3, i - 11).Select
    End With
    Wrd.Selection.TypeText " "
    Wrd.Selection.InlineShapes.AddPicture pic
    Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
    i = i + 1
    End If
End If
DoCmd.GoToRecord , , acNext
Loop
'Error 11
new_modello = GetDBPath & "\segnaletica\" & Me.COEDI & " - " & Me.SIT &
" - " & Me.Laboratorio & ".docx"
ActiveDocument.SaveAs2 (new_modello)
'Doc.Close
Set Doc = Nothing
Set Wrd = Nothing
'Wrd.Quit
grazie

con questo codice io inserisco immagini in word impostando il lato corto
e ridimensionando quello lungo di conseguenza

vedi se fattibile adattarlo al tuo caso



Dim objWordApp As Object
Dim objDoc As Object
Dim objInlineShape As Object


Set objWordApp = CreateObject("Word.Application")


Set objDoc = objWordApp.Documents.Add

Dim imagePath As String
imagePath = "C:\Immagine.jpg"

Set objInlineShape =
objDoc.InlineShapes.AddPicture(FileName:=imagePath, LinkToFile:=False,
SaveWithDocument:=True)

' Ridimensiona l'immagine con lato corto a 100
Dim newWidth As Single
Dim newHeight As Single
Dim shortSideLength As Single

shortSideLength = 100


newWidth = objInlineShape.Width * shortSideLength /
objInlineShape.Height
newHeight = shortSideLength

objInlineShape.LockAspectRatio = False
objInlineShape.Width = newWidth
objInlineShape.Height = newHeight


objWordApp.Visible = True


Set objInlineShape = Nothing
Set objDoc = Nothing
Set objWordApp = Nothing


BFS

[Akery]

Post by BFS

Post by Akery
buongiorno,
con il seguente script inserisco delle immagini in due tabelle di un
documento, tuttavia altune immagini hanno dimensioni spropositate e
vorrei ridurle ad un quadrato di lato massimo 2.5cm. Ho gia provato ad
estrarre in codice da word ma non ha funzionato, il vba word
restituisce solo moveup o movedown per la selezione della immagine.
Suggerimenti?
Dim Wrd As Word.Application
Dim Doc As Word.Document
Dim tbl As Word.Table
Dim pic, tipo As String
GetDBPath = CurrentProject.Path 'nome percorso
CreateObject ("Word.Application")
On Error Resume Next 'gestione errori step by step 'cerca un'istanza
di Word già aperta
Set Wrd = GetObject(, "Word.Application")
If Err.Number = 429 Then 'se c'è stato un errore è perchè Word non era
già aperto: 'aprilo adesso
Set Wrd = CreateObject("Word.Application")
End If
On Error GoTo 0 'ripristina la segnalazione degli errori
Wrd.Visible = True
Wrd.Activate
Set Doc = Wrd.Documents.Add(CurrentProject.Path &
"/ripre.mod.seges.docx")  'nuovo doc
....
Doc.Bookmarks("n_ambiente").Select
Wrd.Selection.TypeText Me.SIT
....
' da questo punto inserisco le immagini
Me![segnaleticaLAB].SetFocus
DoCmd.GoToRecord , , acFirst
i = 0 'contatore obblighi
j = 0 'contatore avvertimenti e divieti
Do While IsNull(Forms!gestione_locale![segnaleticaLAB]!tipo) = False
tipo = Forms!gestione_locale![segnaleticaLAB]!tipo
If tipo = "obbligo" Then
     pic = DLookup("[indirizzo file]", "seges", "[nome segnale]=""" &
Me![segnaleticaLAB]![segnale] & """")
     If j < 6 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 82").Select
     With Selection.Tables(1)
        .Cell(1, j + 1).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     j = j + 1
     ElseIf j >= 6 Then
     MsgBox "hai raggiunto il massimo numero di obblighi!"
     End If
Else
     pic = DLookup("[indirizzo file]", "seges", "[nome segnale]=""" &
Me![segnaleticaLAB]!segnale & """")
     If i < 6 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(1, i + 1).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     ElseIf i >= 6 And i < 12 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(2, i - 5).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     ElseIf i >= 12 And i < 18 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(3, i - 11).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     End If
End If
DoCmd.GoToRecord , , acNext
Loop
'Error 11
new_modello = GetDBPath & "\segnaletica\" & Me.COEDI & " - " & Me.SIT
& " - " & Me.Laboratorio & ".docx"
ActiveDocument.SaveAs2 (new_modello)
'Doc.Close
Set Doc = Nothing
Set Wrd = Nothing
'Wrd.Quit
grazie

con questo codice io inserisco immagini in word impostando il lato corto
e ridimensionando quello lungo di conseguenza
vedi se fattibile adattarlo al tuo caso
 Dim objWordApp As Object
    Dim objDoc As Object
    Dim objInlineShape As Object
    Set objWordApp = CreateObject("Word.Application")
    Set objDoc = objWordApp.Documents.Add
    Dim imagePath As String
    imagePath = "C:\Immagine.jpg"
    Set objInlineShape =
objDoc.InlineShapes.AddPicture(FileName:=imagePath, LinkToFile:=False,
SaveWithDocument:=True)
    ' Ridimensiona l'immagine con lato corto a 100
    Dim newWidth As Single
    Dim newHeight As Single
    Dim shortSideLength As Single
    shortSideLength = 100
    newWidth = objInlineShape.Width * shortSideLength /
objInlineShape.Height
    newHeight = shortSideLength
    objInlineShape.LockAspectRatio = False
    objInlineShape.Width = newWidth
    objInlineShape.Height = newHeight
    objWordApp.Visible = True
    Set objInlineShape = Nothing
    Set objDoc = Nothing
    Set objWordApp = Nothing
BFS

Funziona ma mi cancella la tabella, credo che la mia difficoltà stia nel
fatto che devo far capire ad access che l'immagine da manipolare sia in
una tabella che a sua volta sta in una forma.

a questo punto non so se sia meglio ridurre l'immagime man mano che sono
inserite o fare tutto a documento pronto, il primo caso, a pelle,
dovrebbe essere più facile mentre nel secondo devo fare una ricerca di
tutte le immagini saltando quelle che sono i contorni delle tabelle.

grazie

Grazie

[BFS]

Post by Akery

Post by BFS

Post by Akery
buongiorno,
con il seguente script inserisco delle immagini in due tabelle di un
documento, tuttavia altune immagini hanno dimensioni spropositate e
vorrei ridurle ad un quadrato di lato massimo 2.5cm. Ho gia provato
ad estrarre in codice da word ma non ha funzionato, il vba word
restituisce solo moveup o movedown per la selezione della immagine.
Suggerimenti?
Dim Wrd As Word.Application
Dim Doc As Word.Document
Dim tbl As Word.Table
Dim pic, tipo As String
GetDBPath = CurrentProject.Path 'nome percorso
CreateObject ("Word.Application")
On Error Resume Next 'gestione errori step by step 'cerca un'istanza
di Word già aperta
Set Wrd = GetObject(, "Word.Application")
If Err.Number = 429 Then 'se c'è stato un errore è perchè Word non
era già aperto: 'aprilo adesso
Set Wrd = CreateObject("Word.Application")
End If
On Error GoTo 0 'ripristina la segnalazione degli errori
Wrd.Visible = True
Wrd.Activate
Set Doc = Wrd.Documents.Add(CurrentProject.Path &
"/ripre.mod.seges.docx")  'nuovo doc
....
Doc.Bookmarks("n_ambiente").Select
Wrd.Selection.TypeText Me.SIT
....
' da questo punto inserisco le immagini
Me![segnaleticaLAB].SetFocus
DoCmd.GoToRecord , , acFirst
i = 0 'contatore obblighi
j = 0 'contatore avvertimenti e divieti
Do While IsNull(Forms!gestione_locale![segnaleticaLAB]!tipo) = False
tipo = Forms!gestione_locale![segnaleticaLAB]!tipo
If tipo = "obbligo" Then
     pic = DLookup("[indirizzo file]", "seges", "[nome segnale]=""" &
Me![segnaleticaLAB]![segnale] & """")
     If j < 6 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 82").Select
     With Selection.Tables(1)
        .Cell(1, j + 1).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     j = j + 1
     ElseIf j >= 6 Then
     MsgBox "hai raggiunto il massimo numero di obblighi!"
     End If
Else
     pic = DLookup("[indirizzo file]", "seges", "[nome segnale]=""" &
Me![segnaleticaLAB]!segnale & """")
     If i < 6 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(1, i + 1).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     ElseIf i >= 6 And i < 12 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(2, i - 5).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     ElseIf i >= 12 And i < 18 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(3, i - 11).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     End If
End If
DoCmd.GoToRecord , , acNext
Loop
'Error 11
new_modello = GetDBPath & "\segnaletica\" & Me.COEDI & " - " & Me.SIT
& " - " & Me.Laboratorio & ".docx"
ActiveDocument.SaveAs2 (new_modello)
'Doc.Close
Set Doc = Nothing
Set Wrd = Nothing
'Wrd.Quit
grazie

con questo codice io inserisco immagini in word impostando il lato
corto e ridimensionando quello lungo di conseguenza
vedi se fattibile adattarlo al tuo caso
  Dim objWordApp As Object
     Dim objDoc As Object
     Dim objInlineShape As Object
     Set objWordApp = CreateObject("Word.Application")
     Set objDoc = objWordApp.Documents.Add
     Dim imagePath As String
     imagePath = "C:\Immagine.jpg"
     Set objInlineShape =
objDoc.InlineShapes.AddPicture(FileName:=imagePath, LinkToFile:=False,
SaveWithDocument:=True)
     ' Ridimensiona l'immagine con lato corto a 100
     Dim newWidth As Single
     Dim newHeight As Single
     Dim shortSideLength As Single
     shortSideLength = 100
     newWidth = objInlineShape.Width * shortSideLength /
objInlineShape.Height
     newHeight = shortSideLength
     objInlineShape.LockAspectRatio = False
     objInlineShape.Width = newWidth
     objInlineShape.Height = newHeight
     objWordApp.Visible = True
     Set objInlineShape = Nothing
     Set objDoc = Nothing
     Set objWordApp = Nothing
BFS

Funziona ma mi cancella la tabella, credo che la mia difficoltà stia nel
fatto che devo far capire ad access che l'immagine da manipolare sia in
una tabella che a sua volta sta in una forma.
a questo punto non so se sia meglio ridurre l'immagime man mano che sono
inserite o fare tutto a documento pronto, il primo caso, a pelle,
dovrebbe essere più facile mentre nel secondo devo fare una ricerca di
tutte le immagini saltando quelle che sono i contorni delle tabelle.
grazie
Grazie

potresti usare i segnalibri per far capire esattamente ad access dove
posizionarsi per inserire la foto



BFS

[Akery]

Post by BFS

Post by Akery

Post by BFS

Post by Akery
buongiorno,
con il seguente script inserisco delle immagini in due tabelle di un
documento, tuttavia altune immagini hanno dimensioni spropositate e
vorrei ridurle ad un quadrato di lato massimo 2.5cm. Ho gia provato
ad estrarre in codice da word ma non ha funzionato, il vba word
restituisce solo moveup o movedown per la selezione della immagine.
Suggerimenti?
Dim Wrd As Word.Application
Dim Doc As Word.Document
Dim tbl As Word.Table
Dim pic, tipo As String
GetDBPath = CurrentProject.Path 'nome percorso
CreateObject ("Word.Application")
On Error Resume Next 'gestione errori step by step 'cerca un'istanza
di Word già aperta
Set Wrd = GetObject(, "Word.Application")
If Err.Number = 429 Then 'se c'è stato un errore è perchè Word non
era già aperto: 'aprilo adesso
Set Wrd = CreateObject("Word.Application")
End If
On Error GoTo 0 'ripristina la segnalazione degli errori
Wrd.Visible = True
Wrd.Activate
Set Doc = Wrd.Documents.Add(CurrentProject.Path &
"/ripre.mod.seges.docx")  'nuovo doc
....
Doc.Bookmarks("n_ambiente").Select
Wrd.Selection.TypeText Me.SIT
....
' da questo punto inserisco le immagini
Me![segnaleticaLAB].SetFocus
DoCmd.GoToRecord , , acFirst
i = 0 'contatore obblighi
j = 0 'contatore avvertimenti e divieti
Do While IsNull(Forms!gestione_locale![segnaleticaLAB]!tipo) = False
tipo = Forms!gestione_locale![segnaleticaLAB]!tipo
If tipo = "obbligo" Then
     pic = DLookup("[indirizzo file]", "seges", "[nome segnale]="""
& Me![segnaleticaLAB]![segnale] & """")
     If j < 6 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 82").Select
     With Selection.Tables(1)
        .Cell(1, j + 1).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     j = j + 1
     ElseIf j >= 6 Then
     MsgBox "hai raggiunto il massimo numero di obblighi!"
     End If
Else
     pic = DLookup("[indirizzo file]", "seges", "[nome segnale]="""
& Me![segnaleticaLAB]!segnale & """")
     If i < 6 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(1, i + 1).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     ElseIf i >= 6 And i < 12 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(2, i - 5).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     ElseIf i >= 12 And i < 18 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(3, i - 11).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     End If
End If
DoCmd.GoToRecord , , acNext
Loop
'Error 11
new_modello = GetDBPath & "\segnaletica\" & Me.COEDI & " - " &
Me.SIT & " - " & Me.Laboratorio & ".docx"
ActiveDocument.SaveAs2 (new_modello)
'Doc.Close
Set Doc = Nothing
Set Wrd = Nothing
'Wrd.Quit
grazie

con questo codice io inserisco immagini in word impostando il lato
corto e ridimensionando quello lungo di conseguenza
vedi se fattibile adattarlo al tuo caso
  Dim objWordApp As Object
     Dim objDoc As Object
     Dim objInlineShape As Object
     Set objWordApp = CreateObject("Word.Application")
     Set objDoc = objWordApp.Documents.Add
     Dim imagePath As String
     imagePath = "C:\Immagine.jpg"
     Set objInlineShape =
objDoc.InlineShapes.AddPicture(FileName:=imagePath,
LinkToFile:=False, SaveWithDocument:=True)
     ' Ridimensiona l'immagine con lato corto a 100
     Dim newWidth As Single
     Dim newHeight As Single
     Dim shortSideLength As Single
     shortSideLength = 100
     newWidth = objInlineShape.Width * shortSideLength /
objInlineShape.Height
     newHeight = shortSideLength
     objInlineShape.LockAspectRatio = False
     objInlineShape.Width = newWidth
     objInlineShape.Height = newHeight
     objWordApp.Visible = True
     Set objInlineShape = Nothing
     Set objDoc = Nothing
     Set objWordApp = Nothing
BFS

Funziona ma mi cancella la tabella, credo che la mia difficoltà stia
nel fatto che devo far capire ad access che l'immagine da manipolare
sia in una tabella che a sua volta sta in una forma.
a questo punto non so se sia meglio ridurre l'immagime man mano che
sono inserite o fare tutto a documento pronto, il primo caso, a pelle,
dovrebbe essere più facile mentre nel secondo devo fare una ricerca di
tutte le immagini saltando quelle che sono i contorni delle tabelle.
grazie
Grazie

potresti usare i segnalibri per far capire esattamente ad access dove
posizionarsi per inserire la foto
BFS

ha funzionato e sono riuscito a ciclarla, però ora vorrei impostare le
dimensioni in cm invece che pixel, si può fare?

[Akery]

Post by Akery

Post by BFS

Post by Akery

Post by BFS

Post by Akery
buongiorno,
con il seguente script inserisco delle immagini in due tabelle di
un documento, tuttavia altune immagini hanno dimensioni
spropositate e vorrei ridurle ad un quadrato di lato massimo 2.5cm.
Ho gia provato ad estrarre in codice da word ma non ha funzionato,
il vba word restituisce solo moveup o movedown per la selezione
della immagine. Suggerimenti?
Dim Wrd As Word.Application
Dim Doc As Word.Document
Dim tbl As Word.Table
Dim pic, tipo As String
GetDBPath = CurrentProject.Path 'nome percorso
CreateObject ("Word.Application")
On Error Resume Next 'gestione errori step by step 'cerca
un'istanza di Word già aperta
Set Wrd = GetObject(, "Word.Application")
If Err.Number = 429 Then 'se c'è stato un errore è perchè Word non
era già aperto: 'aprilo adesso
Set Wrd = CreateObject("Word.Application")
End If
On Error GoTo 0 'ripristina la segnalazione degli errori
Wrd.Visible = True
Wrd.Activate
Set Doc = Wrd.Documents.Add(CurrentProject.Path &
"/ripre.mod.seges.docx")  'nuovo doc
....
Doc.Bookmarks("n_ambiente").Select
Wrd.Selection.TypeText Me.SIT
....
' da questo punto inserisco le immagini
Me![segnaleticaLAB].SetFocus
DoCmd.GoToRecord , , acFirst
i = 0 'contatore obblighi
j = 0 'contatore avvertimenti e divieti
Do While IsNull(Forms!gestione_locale![segnaleticaLAB]!tipo) = False
tipo = Forms!gestione_locale![segnaleticaLAB]!tipo
If tipo = "obbligo" Then
     pic = DLookup("[indirizzo file]", "seges", "[nome segnale]="""
& Me![segnaleticaLAB]![segnale] & """")
     If j < 6 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 82").Select
     With Selection.Tables(1)
        .Cell(1, j + 1).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     j = j + 1
     ElseIf j >= 6 Then
     MsgBox "hai raggiunto il massimo numero di obblighi!"
     End If
Else
     pic = DLookup("[indirizzo file]", "seges", "[nome segnale]="""
& Me![segnaleticaLAB]!segnale & """")
     If i < 6 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(1, i + 1).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     ElseIf i >= 6 And i < 12 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(2, i - 5).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     ElseIf i >= 12 And i < 18 Then
     ActiveDocument.Shapes("Rettangolo arrotondato 11").Select
     With Selection.Tables(1)
        .Cell(3, i - 11).Select
     End With
     Wrd.Selection.TypeText " "
     Wrd.Selection.InlineShapes.AddPicture pic
     Wrd.Selection.TypeText Chr(13) & Me![segnaleticaLAB]!segnale
     i = i + 1
     End If
End If
DoCmd.GoToRecord , , acNext
Loop
'Error 11
new_modello = GetDBPath & "\segnaletica\" & Me.COEDI & " - " &
Me.SIT & " - " & Me.Laboratorio & ".docx"
ActiveDocument.SaveAs2 (new_modello)
'Doc.Close
Set Doc = Nothing
Set Wrd = Nothing
'Wrd.Quit
grazie

con questo codice io inserisco immagini in word impostando il lato
corto e ridimensionando quello lungo di conseguenza
vedi se fattibile adattarlo al tuo caso
  Dim objWordApp As Object
     Dim objDoc As Object
     Dim objInlineShape As Object
     Set objWordApp = CreateObject("Word.Application")
     Set objDoc = objWordApp.Documents.Add
     Dim imagePath As String
     imagePath = "C:\Immagine.jpg"
     Set objInlineShape =
objDoc.InlineShapes.AddPicture(FileName:=imagePath,
LinkToFile:=False, SaveWithDocument:=True)
     ' Ridimensiona l'immagine con lato corto a 100
     Dim newWidth As Single
     Dim newHeight As Single
     Dim shortSideLength As Single
     shortSideLength = 100
     newWidth = objInlineShape.Width * shortSideLength /
objInlineShape.Height
     newHeight = shortSideLength
     objInlineShape.LockAspectRatio = False
     objInlineShape.Width = newWidth
     objInlineShape.Height = newHeight
     objWordApp.Visible = True
     Set objInlineShape = Nothing
     Set objDoc = Nothing
     Set objWordApp = Nothing
BFS

Funziona ma mi cancella la tabella, credo che la mia difficoltà stia
nel fatto che devo far capire ad access che l'immagine da manipolare
sia in una tabella che a sua volta sta in una forma.
a questo punto non so se sia meglio ridurre l'immagime man mano che
sono inserite o fare tutto a documento pronto, il primo caso, a
pelle, dovrebbe essere più facile mentre nel secondo devo fare una
ricerca di tutte le immagini saltando quelle che sono i contorni
delle tabelle.
grazie
Grazie

potresti usare i segnalibri per far capire esattamente ad access dove
posizionarsi per inserire la foto
BFS

ha funzionato e sono riuscito a ciclarla, però ora vorrei impostare le
dimensioni in cm invece che pixel, si può fare?

tutto ok, ho fatto il conto a mano e ricavato i pixel necessari per la
corretta centratura.
la porzione di codice aggiunta al ciclo e la seguente

Set immSegnale = Wrd.Selection.InlineShapes.AddPicture(FileName:=pic,
linktofile:=False, savewithdocument:=True)
immSegnale.Width = 60
immSegnale.Height = 60

ancora grazie per il supporto