Skip to content

Instantly share code, notes, and snippets.

@wintercn
Created May 17, 2013 11:10
Show Gist options
  • Save wintercn/5598427 to your computer and use it in GitHub Desktop.
Save wintercn/5598427 to your computer and use it in GitHub Desktop.
把Powerpoint矢量图生成SVG的VBA
' svg.vba released 11.08.2002
Private Function get_export_scaling_factor() As Single
'' point to pixel conversion factor
get_export_scaling_factor = (4 / 3)
End Function
Private Function get_textbox_height_scaling_factor() As Single
'' point to pixel conversion factor, further scaled up by empirically derived factor, 1.3 too small, 1.5 unnecessarily large
get_textbox_height_scaling_factor = (4 / 3) * 1.4142
End Function
Private Function rgb_to_colour_hash(intRGB) As String
'' converts VBA RGB integer to #rrggbb format string
redRGB = Hex(intRGB Mod 256)
If Len(redRGB) = 1 Then
redRGB = "0" & redRGB
End If
greenRGB = Hex(intRGB \ 256 Mod 256)
If Len(greenRGB) = 1 Then
greenRGB = "0" & greenRGB
End If
blueRGB = Hex(intRGB \ 65536 Mod 256)
If Len(blueRGB) = 1 Then
blueRGB = "0" & blueRGB
End If
rgb_to_colour_hash = "#" & redRGB & greenRGB & blueRGB
End Function
Private Function get_points(ByVal s As shape, ByVal scale_factor As Single) As String
'' for any poly-object, creates a string of coord pairs
'' takes into account re-scaling of poly-object
'' why ppt keeps the creation size, goodness knows
''
'' get the original bounding box (bb)
numNodes = s.Nodes.Count
xyCoords = s.Vertices
largest_x = xyCoords(1, 1)
largest_y = xyCoords(1, 2)
For i = 2 To numNodes
If xyCoords(i, 1) > largest_x Then
largest_x = xyCoords(i, 1)
End If
If xyCoords(i, 2) > largest_y Then
largest_y = xyCoords(i, 2)
End If
Next
bb_x = largest_x - s.Left
bb_y = largest_y - s.Top
'' get the ratio, current to original
x_ratio = s.Width / bb_x
y_ratio = s.Height / bb_y
'' establish current top-left origin
x00Coord = (xyCoords(1, 1) - s.Left) * x_ratio
y00Coord = (xyCoords(1, 2) - s.Top) * y_ratio
'' establish current top-left corner
If s.HorizontalFlip Then
x = (s.Left + (s.Width - x00Coord)) * scale_factor
Else
x = (s.Left + x00Coord) * scale_factor
End If
If s.VerticalFlip Then
y = (s.Top + (s.Height - y00Coord)) * scale_factor
Else
y = (s.Top + y00Coord) * scale_factor
End If
strPoints = x & "," & y
'' build remaining points
For i = 2 To numNodes
x00Coord = (xyCoords(i, 1) - s.Left) * x_ratio
y00Coord = (xyCoords(i, 2) - s.Top) * y_ratio
If s.HorizontalFlip Then
x = (s.Left + (s.Width - x00Coord)) * scale_factor
Else
x = (s.Left + x00Coord) * scale_factor
End If
If s.VerticalFlip Then
y = (s.Top + (s.Height - y00Coord)) * scale_factor
Else
y = (s.Top + y00Coord) * scale_factor
End If
strPoints = strPoints & " " & x & "," & y
Next
get_points = strPoints
End Function
Private Function get_svg_line_colour_hash(ByVal s As shape) As String
'' get stroke (colour)
rgbLine = s.Line.ForeColor.RGB
hrgbLine = rgb_to_colour_hash(rgbLine)
get_svg_line_colour_hash = "stroke:" & hrgbLine & ";"
End Function
Private Function get_svg_line_width(ByVal s As shape) As String
'' get stroke-width
swLine = s.Line.Weight
get_svg_line_width = "stroke-width:" & swLine & "pt;"
End Function
Private Function get_svg_line_points(ByVal s As shape) As String
'' get points
export_scaling_factor = get_export_scaling_factor()
If s.HorizontalFlip Then
If s.VerticalFlip Then '' both flips
x1 = s.Left + s.Width
y1 = s.Top + s.Height
x2 = s.Left
y2 = s.Top
Else '' horizontal flip only
x1 = s.Left + s.Width
y1 = s.Top
x2 = s.Left
y2 = s.Top + s.Height
End If
Else '' vertical flip only
If s.VerticalFlip Then
x1 = s.Left
y1 = s.Top + s.Height
x2 = s.Left + s.Width
y2 = s.Top
Else '' no flip of any kind
x1 = s.Left
y1 = s.Top
x2 = s.Left + s.Width
y2 = s.Top + s.Height
End If
End If
x1 = Int(x1 * export_scaling_factor)
y1 = Int(y1 * export_scaling_factor)
x2 = Int(x2 * export_scaling_factor)
y2 = Int(y2 * export_scaling_factor)
get_svg_line_points = "x1=" & Chr$(34) & x1 & Chr$(34) & " y1=" & Chr$(34) & y1 & Chr$(34) & _
" x2=" & Chr$(34) & x2 & Chr$(34) & " y2=" & Chr$(34) & y2 & Chr$(34)
End Function
Private Function substr(ByVal t As String, ByVal f As String, ByVal r As String) As String
If InStr(1, r, f, vbTextCompare) > 0 Then
tStr = ""
tRem = t
posF = InStr(1, tRem, f, vbTextCompare)
While posF > 0
tStr = Left$(tRem, posF - 1) & r
tRem = Right$(tRem, Len(tRem) - (posF + Len(f) - 1))
posF = InStr(1, tRem, f, vbTextCompare)
Wend
tStr = tStr & tRem
Else
tStr = t
posF = InStr(1, tStr, f, vbTextCompare)
While posF > 0
tStr = Left$(tStr, posF - 1) & r & Right$(tStr, Len(tStr) - (posF + Len(f) - 1))
posF = InStr(1, tStr, f, vbTextCompare)
Wend
End If
substr = tStr
End Function
Private Function textbox_to_moz_svg(ByVal s As shape) As String
'' this function utter rot for code fragments
'' need to re-think text box output for moz
export_scaling_factor = get_export_scaling_factor()
x = Int(s.Left * export_scaling_factor)
y = Int(s.Top * export_scaling_factor)
w = Int(s.Width * export_scaling_factor) + 1
h = Int(s.Height * export_scaling_factor) + 1
'' get contents of text box
txtTextBox0 = s.TextFrame.TextRange.Text
txtTextBox1 = substr(txtTextBox0, "&", "&")
txtTextBox2 = substr(txtTextBox1, "<", "&lt;")
txtTextBox = substr(txtTextBox2, ">", "&gt;")
'' get font family
ffText = s.TextFrame.TextRange.Font.Name ' "Arial"
styFamily = "font-family:" & ffText & ";"
'' get font size
fsText = s.TextFrame.TextRange.Font.Size ' 12, 24,...
stySize = "font-size:" & fsText & "pt;"
'' get colour of font
rgbText = s.TextFrame.TextRange.Font.Color.RGB
hrgbText = rgb_to_colour_hash(rgbText)
styFill = "fill:" & hrgbText & ";"
'' get font attributes
fiText = s.TextFrame.TextRange.Font.Italic ' t/f
If fiText Then
styStyle = "font-style:italic;"
Else
styStyle = ""
End If
fbText = s.TextFrame.TextRange.Font.Bold ' t/f
If fbText Then
styWeight = "font-weight:bold;"
Else
styWeight = ""
End If
fuText = s.TextFrame.TextRange.Font.Underline ' t/f
If fuText Then
styDeco = "text-decoration:underline;"
Else
styDeco = ""
End If
h = Int(s.Height * 2) + 1 ' textbox_height_scaling_factor, or 2.0
h1 = s.Height * export_scaling_factor
svgTextBox = " <foreignObject xml:space=" & Chr$(34) & "preserve" & Chr$(34) & " x=" & Chr$(34) & x & Chr$(34) & " y=" & Chr$(34) & y & Chr$(34) & _
" width=" & Chr$(34) & w & Chr$(34) & " height=" & Chr$(34) & h & Chr$(34) & _
" style=" & Chr$(34) & styFamily & stySize & styFill & styStyle & styWeight & styDeco & Chr$(34) & ">" & txtTextBox & _
"</foreignObject>"
textbox_to_moz_svg = svgTextBox
End Function
Private Function get_svg_rect_points(ByVal s As shape) As String
'' get points
export_scaling_factor = get_export_scaling_factor()
x = s.Left
y = s.Top
w = s.Width
h = s.Height
x = Int(x * export_scaling_factor)
y = Int(y * export_scaling_factor)
w = Int(w * export_scaling_factor)
h = Int(h * export_scaling_factor)
get_svg_rect_points = "x=" & Chr$(34) & x & Chr$(34) & " y=" & Chr$(34) & y & Chr$(34) & _
" width=" & Chr$(34) & w & Chr$(34) & " height=" & Chr$(34) & h & Chr$(34)
End Function
Private Function get_svg_rect_fill(ByVal s As shape) As String
'' get fill colour
If s.Fill.Visible = msoFalse Then
hrgbRect = "transparent"
Else
rgbRect = s.Fill.ForeColor.RGB
hrgbRect = rgb_to_colour_hash(rgbRect)
End If
get_svg_rect_fill = "fill:" & hrgbRect & ";"
End Function
Private Function get_svg_rect_stroke_width(ByVal s As shape) As String
'' get stroke-width
swRect = s.Line.Weight
get_svg_rect_stroke_width = "stroke-width:" & swRect & "pt;"
End Function
Private Function get_svg_rect_stroke(ByVal s As shape) As String
'' get stroke (border colour)
If s.Line.Visible = msoFalse Then
hrgbStroke = "transparent"
Else
rgbStroke = s.Line.ForeColor.RGB
hrgbStroke = rgb_to_colour_hash(rgbStroke)
End If
get_svg_rect_stroke = "stroke:" & hrgbStroke & ";"
End Function
Private Function get_svg_ellipse_points(ByVal s As shape) As String
'' get points
export_scaling_factor = get_export_scaling_factor()
x = s.Left
y = s.Top
w = s.Width
h = s.Height
cx = Int((x + (w / 2)) * export_scaling_factor)
cy = Int((y + (h / 2)) * export_scaling_factor)
rx = Int((w / 2) * export_scaling_factor)
ry = Int((h / 2) * export_scaling_factor)
get_svg_ellipse_points = "cx=" & Chr$(34) & cx & Chr$(34) & " cy=" & Chr$(34) & cy & Chr$(34) & _
" rx=" & Chr$(34) & rx & Chr$(34) & " ry=" & Chr$(34) & ry & Chr$(34)
End Function
Private Function get_svg_ellipse_fill(ByVal s As shape) As String
'' get colour
If s.Fill.Visible = msoFalse Then
hrgbEllipse = "transparent"
Else
rgbEllipse = s.Fill.ForeColor.RGB
hrgbEllipse = rgb_to_colour_hash(rgbEllipse)
End If
get_svg_ellipse_fill = "fill:" & hrgbEllipse & ";"
End Function
Private Function get_svg_ellipse_stroke_width(ByVal s As shape) As String
'' get stroke-width
swEllipse = s.Line.Weight
get_svg_ellipse_stroke_width = "stroke-width:" & swEllipse & "pt;"
End Function
Private Function get_svg_ellipse_stroke(ByVal s As shape) As String
'' get stroke (border colour)
If s.Line.Visible = msoFalse Then
hrgbStroke = "transparent"
Else
rgbStroke = s.Line.ForeColor.RGB
hrgbStroke = rgb_to_colour_hash(rgbStroke)
End If
get_svg_ellipse_stroke = "stroke:" & hrgbStroke & ";"
End Function
Private Function get_svg_polygon_fill(ByVal s As shape) As String
'' get fill colour
If s.Fill.Visible = msoFalse Then
hrgbPolygon = "transparent"
Else
rgbPolygon = s.Fill.ForeColor.RGB
hrgbPolygon = rgb_to_colour_hash(rgbPolygon)
End If
get_svg_polygon_fill = "fill:" & hrgbPolygon & ";"
End Function
Private Function get_svg_polygon_stroke(ByVal s As shape) As String
'' get stroke (border colour)
If s.Line.Visible = msoFalse Then
hrgbPolygon = "transparent"
Else
rgbPolygon = s.Line.ForeColor.RGB
hrgbPolygon = rgb_to_colour_hash(rgbPolygon)
End If
get_svg_polygon_stroke = "stroke:" & hrgbPolygon & ";"
End Function
Private Function get_svg_polygon_stroke_width(ByVal s As shape) As String
'' get stroke-width
swPolygon = s.Line.Weight
get_svg_polygon_stroke_width = "stroke-width:" & swPolygon & "pt;"
End Function
Private Function get_svg_polygon_points(ByVal s As shape) As String
export_scaling_factor = get_export_scaling_factor()
strPoints = get_points(s, export_scaling_factor)
get_svg_polygon_points = "points=" & Chr$(34) & strPoints & Chr$(34)
End Function
Private Function get_svg_polyline_stroke(ByVal s As shape) As String
If s.Line.Visible = msoFalse Then
hrgbPolyline = "transparent"
Else
rgbPolyline = s.Line.ForeColor.RGB
hrgbPolyline = rgb_to_colour_hash(rgbPolyline)
End If
get_svg_polyline_stroke = "stroke:" & hrgbPolyline & ";"
End Function
Private Function get_svg_polyline_stroke_width(ByVal s As shape) As String
'' get stroke-width
swPolyline = s.Line.Weight
get_svg_polyline_stroke_width = "stroke-width:" & swPolyline & "pt;"
End Function
Private Function get_svg_polyline_points(ByVal s As shape) As String
'' get points
export_scaling_factor = get_export_scaling_factor()
strPoints = get_points(s, export_scaling_factor)
get_svg_polyline_points = "points=" & Chr$(34) & strPoints & Chr$(34)
End Function
Private Function get_asv_svg_polyline_segment_points(ByVal s As shape, ByVal j As Integer) As String
'' get segment points
export_scaling_factor = get_export_scaling_factor()
pairStart = s.Nodes.Item(j - 1).Points
pairEnd = s.Nodes.Item(j).Points
x1 = Int(pairStart(1, 1) * export_scaling_factor)
y1 = Int(pairStart(1, 2) * export_scaling_factor)
x2 = Int(pairEnd(1, 1) * export_scaling_factor)
y2 = Int(pairEnd(1, 2) * export_scaling_factor)
get_asv_svg_polyline_segment_points = "x1=" & Chr$(34) & x1 & Chr$(34) & " y1=" & Chr$(34) & y1 & Chr$(34) & _
" x2=" & Chr$(34) & x2 & Chr$(34) & " y2=" & Chr$(34) & y2 & Chr$(34)
End Function
Private Function polyline_to_asv_svg(ByVal s As shape) As String
svg_polyline_stroke_width = get_svg_polyline_stroke_width(s)
svg_polyline_stroke = get_svg_polyline_stroke(s)
If s.Line.BeginArrowheadStyle = msoArrowheadOval Then
marker_start = " marker-start=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
marker_start = " marker-start=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadOval Then
marker_end = " marker-end=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadTriangle Then
marker_end = " marker-end=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
numNodes = s.Nodes.Count
If numNodes = 2 Then
svg_line_points = get_asv_svg_polyline_segment_points(s, 2)
svgPolyline = " <line " & svg_line_points & " style=" & Chr$(34) & svg_polyline_stroke & svg_polyline_stroke_width & Chr$(34) & marker_start & marker_end & "/>"
Else
svgPolyline = ""
For j = 2 To numNodes
svg_line_points = get_asv_svg_polyline_segment_points(s, j)
If j = 2 Then
svgLine = " <line " & svg_line_points & " style=" & Chr$(34) & svg_polyline_stroke & svg_polyline_stroke_width & Chr$(34) & marker_start & "/>" & vbCrLf
ElseIf j = numNodes Then
svgLine = " <line " & svg_line_points & " style=" & Chr$(34) & svg_polyline_stroke & svg_polyline_stroke_width & Chr$(34) & marker_end & "/>"
Else
svgLine = " <line " & svg_line_points & " style=" & Chr$(34) & svg_polyline_stroke & svg_polyline_stroke_width & Chr$(34) & "/>" & vbCrLf
End If
svgPolyline = svgPolyline & svgLine
Next
End If
polyline_to_asv_svg = "<!-- " & s.Name & " (polyline_to_asv_svg) -->" & vbCrLf & svgPolyline
End Function
Private Function get_svg_path_stroke(ByVal s As shape) As String
rgbPath = s.Line.ForeColor.RGB
hrgbPath = rgb_to_colour_hash(rgbPath)
get_svg_path_stroke = "stroke:" & hrgbPath & ";"
End Function
Private Function get_svg_path_stroke_width(ByVal s As shape) As String
swPath = s.Line.Weight
get_svg_path_stroke_width = "stroke-width:" & swPath & "pt;"
End Function
Private Function get_svg_path_points(ByVal s As shape) As String
'' need to document theory behind this function properly
export_scaling_factor = get_export_scaling_factor()
numNodes = s.Nodes.Count
xyCoords = s.Vertices ' try vertices, easier
largest_x = xyCoords(1, 1)
largest_y = xyCoords(1, 2)
For i = 2 To numNodes
If xyCoords(i, 1) > largest_x Then
largest_x = xyCoords(i, 1)
End If
If xyCoords(i, 2) > largest_y Then
largest_y = xyCoords(i, 2)
End If
Next
bb_x = largest_x - s.Left
bb_y = largest_y - s.Top
x_ratio = s.Width / bb_x
y_ratio = s.Height / bb_y
x00Coord = (xyCoords(1, 1) - s.Left) * x_ratio
y00Coord = (xyCoords(1, 2) - s.Top) * y_ratio
If s.HorizontalFlip Then
x = (s.Left + (s.Width - x00Coord)) * export_scaling_factor
Else
x = (s.Left + x00Coord) * export_scaling_factor
End If
If s.VerticalFlip Then
y = (s.Top + (s.Height - y00Coord)) * export_scaling_factor
Else
y = (s.Top + y00Coord) * export_scaling_factor
End If
strPath = " M " & x & "," & y
For i = 2 To numNodes
x00Coord = (xyCoords(i, 1) - s.Left) * x_ratio
y00Coord = (xyCoords(i, 2) - s.Top) * y_ratio
If (i Mod 3) = 2 Then
strPath = strPath & " C "
End If
If s.HorizontalFlip Then
x = (s.Left + (s.Width - x00Coord)) * export_scaling_factor
Else
x = (s.Left + x00Coord) * export_scaling_factor
End If
If s.VerticalFlip Then
y = (s.Top + (s.Height - y00Coord)) * export_scaling_factor
Else
y = (s.Top + y00Coord) * export_scaling_factor
End If
strPath = strPath & " " & x & "," & y
Next
get_svg_path_points = "d=" & Chr$(34) & strPath & Chr$(34)
End Function
Private Function get_asv_svg_path_points(ByVal s As shape) As Variant
numNodes = s.Nodes.Count
ReDim strPath(1 To numNodes, 1 To 2) As Single
export_scaling_factor = get_export_scaling_factor()
xyCoords = s.Vertices
largest_x = xyCoords(1, 1)
largest_y = xyCoords(1, 2)
For i = 2 To numNodes
If xyCoords(i, 1) > largest_x Then
largest_x = xyCoords(i, 1)
End If
If xyCoords(i, 2) > largest_y Then
largest_y = xyCoords(i, 2)
End If
Next
bb_x = largest_x - s.Left
bb_y = largest_y - s.Top
x_ratio = s.Width / bb_x
y_ratio = s.Height / bb_y
x00Coord = (xyCoords(1, 1) - s.Left) * x_ratio
y00Coord = (xyCoords(1, 2) - s.Top) * y_ratio
If s.HorizontalFlip Then
x = (s.Left + (s.Width - x00Coord)) * export_scaling_factor
Else
x = (s.Left + x00Coord) * export_scaling_factor
End If
If s.VerticalFlip Then
y = (s.Top + (s.Height - y00Coord)) * export_scaling_factor
Else
y = (s.Top + y00Coord) * export_scaling_factor
End If
strPath(1, 1) = x
strPath(1, 2) = y
For i = 2 To numNodes
x00Coord = (xyCoords(i, 1) - s.Left) * x_ratio
y00Coord = (xyCoords(i, 2) - s.Top) * y_ratio
If s.HorizontalFlip Then
x = (s.Left + (s.Width - x00Coord)) * export_scaling_factor
Else
x = (s.Left + x00Coord) * export_scaling_factor
End If
If s.VerticalFlip Then
y = (s.Top + (s.Height - y00Coord)) * export_scaling_factor
Else
y = (s.Top + y00Coord) * export_scaling_factor
End If
strPath(i, 1) = x
strPath(i, 2) = y
Next
get_asv_svg_path_points = strPath
End Function
Private Function curve_to_asv_svg(ByVal s As shape) As String
'' this now redundant (?)
svg_path_stroke_width = get_svg_path_stroke_width(s)
svg_path_stroke = get_svg_path_stroke(s)
If s.Line.BeginArrowheadStyle = msoArrowheadOval Then
marker_start = " marker-start=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
marker_start = " marker-start=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadOval Then
marker_end = " marker-end=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadTriangle Then
marker_end = " marker-end=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
Dim svg_path_points As Variant
svg_path_points = get_asv_svg_path_points(s)
svgCurve = ""
numNodes = s.Nodes.Count
For j = 2 To numNodes
svg_line_points = "x1=" & Chr$(34) & svg_path_points(j - 1, 1) & Chr$(34) & _
" y1=" & Chr$(34) & svg_path_points(j - 1, 2) & Chr$(34) & _
" x2=" & Chr$(34) & svg_path_points(j, 1) & Chr$(34) & _
" y2=" & Chr$(34) & svg_path_points(j, 2) & Chr$(34)
If j = 2 Then
svgLine = " <line " & svg_line_points & " style=" & Chr$(34) & svg_path_stroke & svg_path_stroke_width & Chr$(34) & marker_start & "/>" & vbCrLf
ElseIf j = numNodes Then
svgLine = " <line " & svg_line_points & " style=" & Chr$(34) & svg_path_stroke & svg_path_stroke_width & Chr$(34) & marker_end & "/>"
Else
svgLine = " <line " & svg_line_points & " style=" & Chr$(34) & svg_path_stroke & svg_path_stroke_width & Chr$(34) & "/>" & vbCrLf
End If
svgCurve = svgCurve & svgLine
Next
curve_to_asv_svg = svgCurve
End Function
Private Function decompose_group(ByVal s As shape, ByVal svgSymbol As String, ByVal hier As Integer) As String
'' need to bring up-to-date with main export_to_svg procedure
tfRotation = False
numShapes = s.GroupItems.Count
For i = 1 To numShapes
Set sr = s.GroupItems(i)
If sr.Rotation <> 0 Then
tfRotation = True
End If
If sr.Type = msoGroup Then
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & " <!--g> < hier = " & hier & " -->"
hier = hier + 1
svgSymbol = decompose_group(sr, svgSymbol, hier)
hier = hier - 1
svgSymbol = svgSymbol & vbCrLf & indent & " <!--/g-->"
ElseIf sr.Type = msoLine Then
svgLine = line_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgLine
ElseIf sr.Type = msoTextBox Then
svgTextBox = textbox_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgTextBox
ElseIf sr.Type = msoFreeform Then
numNodes = sr.Nodes.Count
srCoords = sr.Vertices
If UBound(srCoords, 1) = (numNodes + 1) Then
'' closed polyline or polygon
svgPolygon = polygon_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgPolygon
Else ' not a closed poly-object
If sr.Nodes.Item(1).SegmentType = msoSegmentLine Then
If sr.Fill.Visible Then
'' polyline with fill
svgPolygon = polyline_filled_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgPolygon
Else
'' polyline
svgPolyline = polyline_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgPolyline
End If
Else ' msoSegmentCurve
svgPath = curve_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgPath
End If
End If
ElseIf sr.Type = msoAutoShape Then
If sr.AutoShapeType = msoShapeRectangle Then
svgRect = rect_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgRect
ElseIf sr.AutoShapeType = msoShapeOval Then
svgEllipse = ellipse_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgEllipse
Else
End If
Else
End If
Next
If tfRotation = True Then
End If
decompose_group = svgSymbol
End Function
Private Function moz_decompose_group(ByVal s As shape, ByVal svgSymbol As String, ByVal hier As Integer) As String
'' need to bring up-to-date with main export_to_svg procedure
tfRotation = False
numShapes = s.GroupItems.Count
For i = 1 To numShapes
Set sr = s.GroupItems(i)
If sr.Rotation <> 0 Then
tfRotation = True
End If
If sr.Type = msoGroup Then
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & " <!--g> < hier = " & hier & " -->"
hier = hier + 1
svgSymbol = moz_decompose_group(sr, svgSymbol, hier)
hier = hier - 1
svgSymbol = svgSymbol & vbCrLf & indent & " <!--/g-->"
ElseIf sr.Type = msoLine Then
msgText = sr.Name & " is line"
svgLine = line_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgLine
ElseIf sr.Type = msoTextBox Then
msgText = sr.Name & " is text"
moz_svgTextBox = textbox_to_moz_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & moz_svgTextBox
ElseIf sr.Type = msoFreeform Then
numNodes = sr.Nodes.Count
srCoords = sr.Vertices
If UBound(srCoords, 1) = (numNodes + 1) Then
'' closed polyline or polygon
svgPolygon = polygon_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgPolygon
Else ' not a closed poly-object
If sr.Nodes.Item(1).SegmentType = msoSegmentLine Then
If sr.Fill.Visible Then
'' polyline with fill
svgPolygon = polyline_filled_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgPolygon
Else
'' polyline
svgPolyline = polyline_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgPolyline
End If
Else ' msoSegmentCurve
msgText = sr.Name & " is path"
svgPath = curve_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgPath
End If
End If
ElseIf sr.Type = msoAutoShape Then
If sr.AutoShapeType = msoShapeRectangle Then
svgRect = rect_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgRect
ElseIf sr.AutoShapeType = msoShapeOval Then
svgEllipse = ellipse_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgEllipse
Else
End If
Else
End If
Next
If tfRotation = True Then
End If
moz_decompose_group = svgSymbol
End Function
Private Function asv_decompose_group(ByVal s As shape, ByVal svgSymbol As String, ByVal hier As Integer) As String
'' need to bring up-to-date with main export_to_svg procedure
tfRotation = False
numShapes = s.GroupItems.Count
For i = 1 To numShapes
Set sr = s.GroupItems(i)
If sr.Rotation <> 0 Then
tfRotation = True
End If
If sr.Type = msoGroup Then
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & " <!--g> < hier = " & hier & " -->"
hier = hier + 1
svgSymbol = asv_decompose_group(sr, svgSymbol, hier)
hier = hier - 1
svgSymbol = svgSymbol & vbCrLf & indent & " <!--/g-->"
ElseIf sr.Type = msoLine Then
svgLine = line_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgLine
ElseIf sr.Type = msoTextBox Then
svgTextBox = textbox_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgTextBox
ElseIf sr.Type = msoFreeform Then
numNodes = sr.Nodes.Count
srCoords = sr.Vertices
If UBound(srCoords, 1) = (numNodes + 1) Then
'' closed polyline or polygon
svgPolygon = polygon_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgPolygon
Else ' not a closed poly-object
If sr.Nodes.Item(1).SegmentType = msoSegmentLine Then
If sr.Fill.Visible Then
'' polyline with fill
svgPolygon = polyline_filled_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgPolygon
Else
asv_svgPolyline = polyline_to_asv_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & asv_svgPolyline
End If
Else ' msoSegmentCurve
msgText = sr.Name & " is path"
asv_svgPath = curve_to_asv_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & asv_svgPath
End If
End If
ElseIf sr.Type = msoAutoShape Then
If sr.AutoShapeType = msoShapeRectangle Then
svgRect = rect_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgRect
ElseIf sr.AutoShapeType = msoShapeOval Then
svgEllipse = ellipse_to_svg(sr)
indent = String((hier * 2), " ")
svgSymbol = svgSymbol & vbCrLf & indent & svgEllipse
Else
End If
Else
End If
Next
If tfRotation = True Then
End If
asv_decompose_group = svgSymbol
End Function
Private Function create_defs_text()
'' black markers - this could be made cleverer by dynamically writing the SVG as an arrow'ed object is encountered
txtDefs = " <defs>" & vbCrLf
txtDefs = txtDefs & " <marker id=" & Chr$(34) & "Triangle" & Chr$(34) & vbCrLf
txtDefs = txtDefs & " viewBox=" & Chr$(34) & "-10 0 10 10" & Chr$(34) & " refX=" & Chr$(34) & "0" & Chr$(34) & " refY=" & Chr$(34) & "5" & Chr$(34) & vbCrLf
txtDefs = txtDefs & " markerUnits = " & Chr$(34) & "strokeWidth" & Chr$(34) & vbCrLf
txtDefs = txtDefs & " markerWidth=" & Chr$(34) & "8" & Chr$(34) & " markerHeight=" & Chr$(34) & "6" & Chr$(34) & vbCrLf
txtDefs = txtDefs & " orient=" & Chr$(34) & "auto" & Chr$(34) & " style=" & Chr$(34) & "fill:3F80CD;" & Chr$(34) & ">" & vbCrLf
txtDefs = txtDefs & " <polygon points=" & Chr$(34) & "-15,0 1,5 -15,10" & Chr$(34) & " />" & vbCrLf
txtDefs = txtDefs & " </marker>" & vbCrLf
txtDefs = txtDefs & " <marker id=" & Chr$(34) & "Circle" & Chr$(34) & vbCrLf
txtDefs = txtDefs & " viewBox=" & Chr$(34) & "0 0 10 10" & Chr$(34) & " refX=" & Chr$(34) & "0" & Chr$(34) & " refY=" & Chr$(34) & "5" & Chr$(34) & vbCrLf
txtDefs = txtDefs & " markerUnits = " & Chr$(34) & "strokeWidth" & Chr$(34) & vbCrLf
txtDefs = txtDefs & " markerWidth=" & Chr$(34) & "8" & Chr$(34) & " markerHeight=" & Chr$(34) & "6" & Chr$(34) & vbCrLf
txtDefs = txtDefs & " orient=" & Chr$(34) & "auto" & Chr$(34) & " style=" & Chr$(34) & "fill:black;" & Chr$(34) & ">" & vbCrLf
txtDefs = txtDefs & " <circle cx=" & Chr$(34) & "5" & Chr$(34) & " cy=" & Chr$(34) & "5" & Chr$(34) & " r=" & Chr$(34) & "4" & Chr$(34) & " />" & vbCrLf
txtDefs = txtDefs & " </marker>" & vbCrLf
create_defs_text = txtDefs & " </defs>"
End Function
Private Function line_to_svg(ByVal s As shape) As String
svg_line_points = get_svg_line_points(s)
svg_line_colour = get_svg_line_colour_hash(s)
svg_line_width = get_svg_line_width(s)
If s.Line.BeginArrowheadStyle = msoArrowheadOval Then
marker_start = " marker-start=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
marker_start = " marker-start=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadOval Then
marker_end = " marker-end=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadTriangle Then
marker_end = " marker-end=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
svgLine = " <line " & svg_line_points & " style=" & Chr$(34) & svg_line_colour & svg_line_width & Chr$(34) & marker_start & marker_end & "/>"
line_to_svg = svgLine
End Function
Private Function shape_text_to_svg(ByVal s As shape) As String
export_scaling_factor = get_export_scaling_factor()
vertical_offset = s.TextFrame.TextRange.Font.Size
x = Int(s.Left * export_scaling_factor)
y = Int(s.Top * export_scaling_factor) + vertical_offset
w = Int(s.Width * export_scaling_factor) + 1
h = Int(s.Height * export_scaling_factor) + 1
'' get contents of text box
txtTextBox = s.TextFrame.TextRange.Text
'' get font family
ffText = s.TextFrame.TextRange.Font.Name ' "Arial"
styFamily = "font-family:" & ffText & ";"
'' get font size
fsText = s.TextFrame.TextRange.Font.Size ' 12, 24,...
stySize = "font-size:" & fsText & "pt;"
'' get colour of font
rgbText = s.TextFrame.TextRange.Font.Color.RGB
hrgbText = rgb_to_colour_hash(rgbText)
styFill = "fill:" & hrgbText & ";"
'' get font attributes
fiText = s.TextFrame.TextRange.Font.Italic ' t/f
If fiText Then
styStyle = "font-style:italic;"
Else
styStyle = ""
End If
fbText = s.TextFrame.TextRange.Font.Bold ' t/f
If fbText Then
styWeight = "font-weight:bold;"
Else
styWeight = ""
End If
fuText = s.TextFrame.TextRange.Font.Underline ' t/f
If fuText Then
styDeco = "text-decoration:underline;"
Else
styDeco = ""
End If
'' determine num of lines - this allows the use of tspan in the svg
'' thus it supports multi-line text boxes
numLines = 1
txtLine = s.TextFrame.TextRange.Lines(1)
While txtLine <> ""
numLines = numLines + 1
txtLine = s.TextFrame.TextRange.Lines(numLines)
Wend
numLines = numLines - 1
If numLines > 1 Then
''txtTextBox = s.TextFrame.TextRange.Lines(1)
txtLine0 = s.TextFrame.TextRange.Lines(1)
txtLine1 = substr(txtLine0, "&", "&amp;")
txtLine2 = substr(txtLine1, "<", "&lt;")
txtTextBox = substr(txtLine2, ">", "&gt;")
dy = Int(fsText * export_scaling_factor) + 1
For i = 2 To numLines
''txtLine = s.TextFrame.TextRange.Lines(i)
txtLine0 = s.TextFrame.TextRange.Lines(i)
txtLine1 = substr(txtLine0, "&", "&amp;")
txtLine2 = substr(txtLine1, "<", "&lt;")
txtLine = substr(txtLine2, ">", "&gt;")
txtTextBoxLine = " <tspan x=" & Chr$(34) & x & Chr$(34) & " dy=" & Chr$(34) & dy & Chr$(34) & ">" & txtLine & "</tspan>"
txtTextBox = txtTextBox & vbCrLf & txtTextBoxLine
Next
svgTextBox = " <text xml:space=" & Chr$(34) & "preserve" & Chr$(34) & " x=" & Chr$(34) & x & Chr$(34) & " y=" & Chr$(34) & y & Chr$(34) & _
" width=" & Chr$(34) & w & Chr$(34) & " height=" & Chr$(34) & h & Chr$(34) & _
" style=" & Chr$(34) & styFamily & stySize & styFill & styStyle & styWeight & styDeco & Chr$(34) & ">" & txtTextBox & "</text>"
Else '' single-line text box
txtLine0 = s.TextFrame.TextRange.Lines(1)
txtLine1 = substr(txtLine0, "&", "&amp;")
txtLine2 = substr(txtLine1, "<", "&lt;")
txtLine = substr(txtLine2, ">", "&gt;")
svgTextBox = " <text xml:space=" & Chr$(34) & "preserve" & Chr$(34) & " x=" & Chr$(34) & x & Chr$(34) & " y=" & Chr$(34) & y & Chr$(34) & _
" width=" & Chr$(34) & w & Chr$(34) & " height=" & Chr$(34) & h & Chr$(34) & _
" style=" & Chr$(34) & styFamily & stySize & styFill & styStyle & styWeight & styDeco & Chr$(34) & ">" & txtLine & "</text>"
End If
textbox_to_svg = svgTextBox
End Function
Private Function textbox_to_svg(ByVal s As shape) As String
export_scaling_factor = get_export_scaling_factor()
vertical_offset = s.TextFrame.TextRange.Font.Size
x = Int(s.Left * export_scaling_factor)
y = Int(s.Top * export_scaling_factor) + vertical_offset
w = Int(s.Width * export_scaling_factor) + 1
h = Int(s.Height * export_scaling_factor) + 1
'' get contents of text box
txtTextBox = s.TextFrame.TextRange.Text
'' get font family
ffText = s.TextFrame.TextRange.Font.Name ' "Arial"
styFamily = "font-family:" & ffText & ";"
'' get font size
fsText = s.TextFrame.TextRange.Font.Size ' 12, 24,...
stySize = "font-size:" & fsText & "pt;"
'' get colour of font
rgbText = s.TextFrame.TextRange.Font.Color.RGB
hrgbText = rgb_to_colour_hash(rgbText)
styFill = "fill:" & hrgbText & ";"
'' get font attributes
fiText = s.TextFrame.TextRange.Font.Italic ' t/f
If fiText Then
styStyle = "font-style:italic;"
Else
styStyle = ""
End If
fbText = s.TextFrame.TextRange.Font.Bold ' t/f
If fbText Then
styWeight = "font-weight:bold;"
Else
styWeight = ""
End If
fuText = s.TextFrame.TextRange.Font.Underline ' t/f
If fuText Then
styDeco = "text-decoration:underline;"
Else
styDeco = ""
End If
'' determine num of lines - this allows the use of tspan in the svg
'' thus it supports multi-line text boxes
numLines = 1
txtLine = s.TextFrame.TextRange.Lines(1)
While txtLine <> ""
numLines = numLines + 1
txtLine = s.TextFrame.TextRange.Lines(numLines)
Wend
numLines = numLines - 1
If numLines > 1 Then
''txtTextBox = s.TextFrame.TextRange.Lines(1)
txtLine0 = s.TextFrame.TextRange.Lines(1)
txtLine1 = substr(txtLine0, "&", "&amp;")
txtLine2 = substr(txtLine1, "<", "&lt;")
txtTextBox = substr(txtLine2, ">", "&gt;")
dy = Int(fsText * export_scaling_factor) + 1
For i = 2 To numLines
''txtLine = s.TextFrame.TextRange.Lines(i)
txtLine0 = s.TextFrame.TextRange.Lines(i)
txtLine1 = substr(txtLine0, "&", "&amp;")
txtLine2 = substr(txtLine1, "<", "&lt;")
txtLine = substr(txtLine2, ">", "&gt;")
txtTextBoxLine = " <tspan x=" & Chr$(34) & x & Chr$(34) & " dy=" & Chr$(34) & dy & Chr$(34) & ">" & txtLine & "</tspan>"
txtTextBox = txtTextBox & vbCrLf & txtTextBoxLine
Next
svgTextBox = " <text xml:space=" & Chr$(34) & "preserve" & Chr$(34) & " x=" & Chr$(34) & x & Chr$(34) & " y=" & Chr$(34) & y & Chr$(34) & _
" width=" & Chr$(34) & w & Chr$(34) & " height=" & Chr$(34) & h & Chr$(34) & _
" style=" & Chr$(34) & styFamily & stySize & styFill & styStyle & styWeight & styDeco & Chr$(34) & ">" & txtTextBox & "</text>"
Else '' single-line text box
txtLine0 = s.TextFrame.TextRange.Lines(1)
txtLine1 = substr(txtLine0, "&", "&amp;")
txtLine2 = substr(txtLine1, "<", "&lt;")
txtLine = substr(txtLine2, ">", "&gt;")
svgTextBox = " <text xml:space=" & Chr$(34) & "preserve" & Chr$(34) & " x=" & Chr$(34) & x & Chr$(34) & " y=" & Chr$(34) & y & Chr$(34) & _
" width=" & Chr$(34) & w & Chr$(34) & " height=" & Chr$(34) & h & Chr$(34) & _
" style=" & Chr$(34) & styFamily & stySize & styFill & styStyle & styWeight & styDeco & Chr$(34) & ">" & txtLine & "</text>"
End If
textbox_to_svg = svgTextBox
End Function
Private Function curve_to_svg(ByVal s As shape) As String
svg_path_points = get_svg_path_points(s)
svg_path_stroke_width = get_svg_path_stroke_width(s)
svg_path_stroke = get_svg_path_stroke(s)
If s.Line.BeginArrowheadStyle = msoArrowheadOval Then
marker_start = " marker-start=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
marker_start = " marker-start=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadOval Then
marker_end = " marker-end=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadTriangle Then
marker_end = " marker-end=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
curve_to_svg = " <path " & svg_path_points & " style=" & Chr$(34) & "fill:transparent;" & svg_path_stroke & svg_path_stroke_width & Chr$(34) & marker_start & marker_end & "/>"
End Function
Private Function polyline_to_svg(ByVal s As shape) As String
svg_polyline_points = get_svg_polyline_points(s)
svg_polyline_stroke_width = get_svg_polyline_stroke_width(s)
svg_polyline_stroke = get_svg_polyline_stroke(s)
If s.Line.BeginArrowheadStyle = msoArrowheadOval Then
marker_start = " marker-start=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
marker_start = " marker-start=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadOval Then
marker_end = " marker-end=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadTriangle Then
marker_end = " marker-end=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
polyline_to_svg = " <polyline " & svg_polyline_points & " style=" & Chr$(34) & svg_polyline_stroke & svg_polyline_stroke_width & Chr$(34) & marker_start & marker_end & "/>"
End Function
Private Function polyline_filled_to_svg(ByVal s As shape) As String
svg_polyline_points = get_svg_polyline_points(s)
svg_polygon_fill = get_svg_polygon_fill(s)
svg_polyline_stroke_width = get_svg_polyline_stroke_width(s)
svg_polyline_stroke = get_svg_polyline_stroke(s)
If s.Line.BeginArrowheadStyle = msoArrowheadOval Then
marker_start = " marker-start=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.BeginArrowheadStyle = msoArrowheadTriangle Then
marker_start = " marker-start=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadOval Then
marker_end = " marker-end=" & Chr$(34) & "url(#Circle)" & Chr$(34)
End If
If s.Line.EndArrowheadStyle = msoArrowheadTriangle Then
marker_end = " marker-end=" & Chr$(34) & "url(#Triangle)" & Chr$(34)
End If
polyline_filled_to_svg = " <polyline " & svg_polyline_points & " style=" & Chr$(34) & svg_polygon_fill & svg_polyline_stroke & svg_polyline_stroke_width & Chr$(34) & marker_start & marker_end & "/>"
End Function
Private Function polygon_to_svg(ByVal s As shape) As String
svg_polygon_points = get_svg_polygon_points(s)
svg_polygon_fill = get_svg_polygon_fill(s)
svg_polygon_stroke_width = get_svg_polygon_stroke_width(s)
svg_polygon_stroke = get_svg_polygon_stroke(s)
polygon_to_svg = " <polygon " & svg_polygon_points & " style=" & Chr$(34) & svg_polygon_fill & svg_polygon_stroke & svg_polygon_stroke_width & Chr$(34) & "/>"
End Function
Private Function rect_to_svg(ByVal s As shape) As String
svg_rect_points = get_svg_rect_points(s)
svg_rect_fill = get_svg_rect_fill(s)
svg_rect_stroke_width = get_svg_rect_stroke_width(s)
svg_rect_stroke = get_svg_rect_stroke(s)
rect_to_svg = " <rect " & svg_rect_points & " style=" & Chr$(34) & svg_rect_fill & svg_rect_stroke & svg_rect_stroke_width & Chr$(34) & "/>"
End Function
Private Function ellipse_to_svg(ByVal s As shape) As String
svg_ellipse_points = get_svg_ellipse_points(s)
svg_ellipse_fill = get_svg_ellipse_fill(s)
svg_ellipse_stroke_width = get_svg_ellipse_stroke_width(s)
svg_ellipse_stroke = get_svg_ellipse_stroke(s)
ellipse_to_svg = " <ellipse " & svg_ellipse_points & " style=" & Chr$(34) & svg_ellipse_fill & svg_ellipse_stroke & svg_ellipse_stroke_width & Chr$(34) & "/>"
End Function
Sub export_to_svg()
'' before release find a way to parameterise these variables
fnAsv = "export.asv.svg"
fnSvg = "export.svg"
fnXML = "export.svg.xml"
Set propsDoc = Application.ActivePresentation.BuiltInDocumentProperties
titleDoc = "svg" ''propsDoc.Item("Title")
descDoc = propsDoc.Item("Comments")
Open fnXML For Output As #2
Print #2, " <svg xmlns=" & Chr$(34) & "http://www.w3.org/2000/svg" & Chr$(34) & _
" width=" & Chr$(34); "2048" & Chr$(34) & " height=" & Chr$(34) & "1536" & Chr$(34) & ">"
Print #2, " <title>" & titleDoc & "</title>"
Print #2, " <desc>" & descDoc & "</desc>"
txtDefs = create_defs_text()
Print #2, txtDefs
Set myDocument = ActivePresentation.Slides(1)
tfRotation = False
tfSymbol = False
numShapes = myDocument.Shapes.Count
For i = 1 To numShapes
Set s = myDocument.Shapes(i)
If s.Rotation <> 0 Then
tfRotation = True
End If
If s.Type = msoGroup Then
tfSymbol = True
svgGroup = "" '' " <!--g-->"
moz_svgGroup = "" '' " <!--g-->"
asv_svgGroup = "" '' " <!--g-->"
hier = 1
svgGroup = decompose_group(s, svgGroup, hier)
moz_svgGroup = moz_decompose_group(s, moz_svgGroup, hier)
asv_svgGroup = asv_decompose_group(s, asv_svgGroup, hier)
Print #2, moz_svgGroup & vbCrLf & " <!--/g-->"
ElseIf s.Type = msoLine Then
svgLine = line_to_svg(s)
Print #2, svgLine
ElseIf s.Type = msoTextBox Then
svgTextBox = textbox_to_svg(s)
moz_svgTextBox = textbox_to_moz_svg(s)
Print #2, moz_svgTextBox
ElseIf s.Type = msoFreeform Then
numNodes = s.Nodes.Count
sCoords = s.Vertices
If UBound(sCoords, 1) = (numNodes + 1) Then
'' closed polyline or polygon
svgPolygon = polygon_to_svg(s)
Print #2, svgPolygon
Else ' not a closed poly-object
If s.Nodes.Item(1).SegmentType = msoSegmentLine Then
If s.Fill.Visible Then
'' polyline with fill
svgPolygon = polyline_filled_to_svg(s)
Print #2, svgPolygon
Else
'' polyline
svgPolyline = polyline_to_svg(s)
Print #2, svgPolyline
End If
Else ' msoSegmentCurve
svgPath = curve_to_svg(s)
Print #2, svgPath
End If
End If
ElseIf s.Type = msoAutoShape Then
If s.AutoShapeType = msoShapeRectangle Then
svgRect = rect_to_svg(s)
Print #2, svgRect
ElseIf s.AutoShapeType = msoShapeOval Then
svgEllipse = ellipse_to_svg(s)
Print #2, svgEllipse
Else
msgText = s.Name & " is unknown AutoShape"
End If
Else
msgText = s.Name & " is unknown Shape"
End If
Next
Print #2, " </svg>"
Close #2
If tfRotation = True Then
End If
If tfSymbol = True Then
End If
End Sub
@lyuehh
Copy link

lyuehh commented May 17, 2013

果然是大神。。

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment