View Single Post
  #9  
Old 11-03-2017, 07:54
WernerHo WernerHo is offline
Junior Member
 
Join Date: Jan 2008
Posts: 20
Default

Hello Shark
this sounds like a very, very good Idea, because it would make my Code much more effectiv.
But
I don't realy understand where in my Code this new Part could be placed.
Even it may be a problem that that, what I paste is a Group of up to 40 Shapes within Text. I dont' know if VBA finds the rectangelshapes in a group of many shapes with each has text in it.

My Code ist:
Code:
Option Explicit
Sub Thor_o_Mat()
Dim shp As Shape, SB As Double, SH As Double
Dim OrigSelection As ShapeRange
Dim PY As Double, PX As Double
ActiveDocument.BeginCommandGroup "Schilder"
Optimization = True
EventsEnabled = False
ActiveDocument.SaveSettings
ActiveDocument.PreserveSelection = False
ActiveLayer.Paste
   Set OrigSelection = ActiveSelectionRange
'   ActiveSelection.Ungroup
For Each shp In ActivePage.Shapes

'*******************************
shp.Shapes.FindShape(, cdrRectangleShape).Outline.Width = 0.003
'*************************   Would this be the right place????

If shp.Type = 3 Then
SB = Round((shp.SizeWidth * 2.54), 0)
SH = Round((shp.SizeHeight * 2.54), 0)
SB = SB / 2.54 + 0.005
SH = SH / 2.54 + 0.005
shp.Fill.ApplyNoFill
'PX = shp.PositionX
'PY = shp.PositionY
   With shp
        .SizeHeight = SH
        .SizeWidth = SB
'        .PositionX = PX - 0.02
'        .PositionY = PY + 0.02
        .Outline.Type = cdrOutline
        .Outline.Width = 0.003
        .Outline.Color.RGBAssign 255, 0, 0
    End With
End If
Next shp
ActiveDocument.PreserveSelection = True
ActiveDocument.RestoreSettings
EventsEnabled = True
Optimization = False
ActiveDocument.EndCommandGroup
ActiveWindow.Refresh
Application.Refresh
End Sub
But in the "For each shp..." Part I get en Error...
(The following Code is, what I used to change Linethickness)
Sorry but my VBA isn't very advanced.
Can you help again?

Last edited by WernerHo; 11-03-2017 at 08:30.
Reply With Quote