1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
| Sub ChangeTagComplexe(StrRch() As String, TypObj As Integer)
'with selected graphs, macro runs through each datasheet of each graph and determines how many rows and columns are included in graph
'asteric chain is where we will add the replace function to perform a replace on each cell in the datasheet of the graph
'TypObj = 1 = selected objects
'TypObj = 2 = all objects
'TypObj = 3 = graph
'TypObj = 4 = textbox
'TypObj = 5 = wordart
'TypObj = 6 = Excel Object
' Object variables
Dim oGraphChart As Object
Dim oDatasheet As Object
Dim oSh As Shape
' Misc variables
Dim lCol As Long
Dim lRow As Long
Dim LastCol As Long
Dim LastRow As Long
Dim X As Long
Dim C, CC, CCC As Long
Dim MaxRows As Long
Dim MaxColumns As Long
Dim Nom_Obj() As String
C = ActiveWindow.Selection.ShapeRange.Count
ReDim Nom_Obj(C + 1)
For CC = 1 To C
Nom_Obj(CC) = ActiveWindow.Selection.ShapeRange(CC).Name
Next CC
For CC = 1 To C
'for each object on slide
ActiveWindow.Selection.SlideRange.Shapes.SelectAll
ActiveWindow.Selection.ShapeRange(Nom_Obj(CC)).Select
Set oSh = ActiveWindow.Selection.ShapeRange(1)
If oSh.Type = msoEmbeddedOLEObject And (TypObj = 1 Or TypObj = 2) Then
'edit datagrid in graph
MaxRows = 100
MaxColumns = 100
Set oGraphChart = oSh.OLEFormat.Object
Set oDatasheet = oGraphChart.Application.datasheet
With oDatasheet
' Find LastRow
For X = 1 To MaxRows
If .Rows(X).Include Then
LastRow = X
End If
Next X
' Find LastCol
For X = 1 To MaxColumns
If .Columns(X).Include Then
LastCol = X
End If
Next X
' Fill in the data
For lCol = 0 To LastCol - 1
For lRow = 0 To LastRow - 1
If lCol = 0 Then
For CCC = 1 To 25
If CStr(StrRch(CCC, 1)) <> "" Then
If FrmTagRepl.CaseTrue = True Then
.Range("0" & CStr(lRow)).Value = Replace(.Range("0" & CStr(lRow)).Value, StrRch(CCC, 1), StrRch(CCC, 2))
Else
.Range("0" & CStr(lRow)).Value = Replace(.Range("0" & CStr(lRow)).Value, StrRch(CCC, 1), StrRch(CCC, 2), , , vbTextCompare)
End If
End If
Next CCC
Else
For CCC = 1 To 25
If CStr(StrRch(CCC, 1)) <> "" Then
If FrmTagRepl.CaseTrue = True Then
.Range(Chr(96 + lCol) & CStr(lRow)).Value = Replace(.Range(Chr(96 + lCol) & CStr(lRow)).Value, StrRch(CCC, 1), StrRch(CCC, 2))
Else
.Range(Chr(96 + lCol) & CStr(lRow)).Value = Replace(.Range(Chr(96 + lCol) & CStr(lRow)).Value, StrRch(CCC, 1), StrRch(CCC, 2), , , vbTextCompare)
End If
End If
Next CCC
End If
Next lRow
Next lCol
End With
oSh.OLEFormat.DoVerb Index:=1
'ActiveWindow.Selection.SlideRange.Shapes.SelectAll
ActivePresentation.Save
'end edit datagrid in graph
oGraphChart.Application.Quit
ElseIf (oSh.Type = msoTextBox Or oSh.Type = msoPlaceholder Or oSh.Type = 1) And (TypObj = 1 Or TypObj = 3) Then
'edit text box
For CCC = 1 To 25
If CStr(StrRch(CCC, 1)) <> "" Then
If FrmTagRepl.CaseTrue = True Then
oSh.TextFrame.TextRange.Text = Replace(oSh.TextFrame.TextRange.Text, StrRch(CCC, 1), StrRch(CCC, 2))
Else
oSh.TextFrame.TextRange.Text = Replace(oSh.TextFrame.TextRange.Text, StrRch(CCC, 1), StrRch(CCC, 2), , , vbTextCompare)
End If
End If
Next CCC
ElseIf oSh.Type = msoTextEffect And (TypObj = 1 Or TypObj = 4) Then
For CCC = 1 To 25
If CStr(StrRch(CCC, 1)) <> "" Then
If FrmTagRepl.CaseTrue = True Then
oSh.TextEffect.Text = Replace(oSh.TextEffect.Text, StrRch(CCC, 1), StrRch(CCC, 2))
Else
oSh.TextEffect.Text = Replace(oSh.TextEffect.Text, StrRch(CCC, 1), StrRch(CCC, 2), , , vbTextCompare)
End If
End If
Next CCC
ElseIf oSh.Type = 6 And (TypObj = 1) Then
'*********************************************
'code needed here to edit embedded Excel object
'1: determine the last column and row of active sheet
'2: go over each cell and perform replace function
'*********************************************
End If
Next CC
End Sub
|