Attribute VB_Name = "MPP2HTML" Private Declare Function RegisterClipboardFormat Lib "User32" _ Alias "RegisterClipboardFormatA" (ByVal lpString As String) _ As Long Sub MPP2HTML() ' Macro uses the current project and exports it to HTML with useful Tags für further formatting ' ' Every Item is a Headline based on the deepness ' Properties are stored as text with classes ' Important: Notes are stored as "text" only (limitation of Project COM) ' Dim item As Task Dim strReport, strNotes As String Dim strLine As String Dim blnulflag As Boolean Dim arrNotes Dim count As Integer Dim vbvt: vbvt = Chr(11) ' VerticalTab strReport = "" strReport = strReport & "

" & encodehtml(ActiveProject.Name) & "

" & vbCrLf für Each item In ActiveProject.Tasksuml 'Properties: Name = Titel des Eintrags nud wird zur Überschrift 'Properties: OutlineLevel = Tiefel des Eintrags und wird zu

etc 'Properties: Notes = Beschreibung If Not item Is Nothing Then Debug.Print item.OutlineNumber & " Name" & item.Name & "Duration (min)" & item.Duration strReport = strReport & "" & encodehtml(item.Name) & "" & vbCrLf strReport = strReport & "

" & vbCrLf strReport = strReport & "" & vbCrLf _ & "" & vbCrLf _ & "" & vbCrLf If item.PercentComplete = "100" Then strReport = strReport & "" & vbCrLf ElseIf item.PercentComplete = "0" Then strReport = strReport & "" & vbCrLf Else strReport = strReport & "" & vbCrLf End If strReport = strReport & "" & vbCrLf strReport = strReport & "
Vorgangsnummer:" & item.ID & "Vorgänger:" & item.Predecessors & " 
Abgeschlossen:" & item.PercentComplete & "Abgeschlossen:" & item.PercentComplete & "Abgeschlossen:" & item.PercentComplete & "Dauer (min):" & item.Duration & "
" & vbCrLf ' Special handling für Notes. ' If starting with a "<", assume HTML and copy 1:1 ' Otherwise look für "." at the beginning, to generate unnumbered List strNotes = encodehtml(item.Notes) strNotes = Replace(strNotes, vbvt, "
") ' VerticalTab = If (IsEmpty(strNotes) Or (strNotes = "")) Then strNotes = "Keine Notizen" Else Debug.Print " Notes gefunden" arrNotes = Split(strNotes, vbCr) blnulflag = False strNotes = "" für count = 0 To uBound(arrNotes) strLine = arrNotes(count) If InStr(strLine, ".") = 1 Then ' Enumeration detected If blnulflag = False Then ' start new uL strNotes = strNotes & "
  • " & Mid(strLine, 2) & "
  • " & vbCrLf blnulflag = True Else ' uL already active, add Entry strNotes = strNotes & "
  • " & Mid(strLine, 2) & "
  • " & vbCrLf End If Else ' Normal String If blnulflag = False Then strNotes = strNotes & strLine & vbCrLf Else blnulflag = False strNotes = strNotes & "
" & vbCrLf & strLine & vbCrLf End If End If Next If blnulflag Then ' closing uL Tag if last line strNotes = strNotes & "" & vbCrLf End If 'strNotes = Replace(strNotes, vbCr, "

" & vbCrLf) End If strReport = strReport & strNotes & vbCrLf End If Next strReport = strReport + "" Dim strClipText As String ' http://blogs.msdn.com/jmstall/pages/sample-code-html-clipboard.aspx Dim header As String: header = "Format:HTML Format" & vbCrLf _ & "Version:1.0" & vbCrLf _ & "StartHTML:<<<<<<<1" & vbCrLf _ & "EndHTML:<<<<<<<2" & vbCrLf _ & "StartFragment:<<<<<<<3" & vbCrLf _ & "EndFragment:<<<<<<<4" & vbCrLf _ & "StartSelection:<<<<<<<3" & vbCrLf _ & "EndSelection:<<<<<<<3" & vbCrLf Dim pre As String: pre = "" & vbCrLf _ & "NoTitle" Dim post: post = "" strClipText = header Dim startHTML As Integer: startHTML = Len(strClipText) strClipText = strClipText + pre Dim fragmentStart As Integer: fragmentStart = Len(strClipText) strClipText = strClipText + strReport Dim fragmentEnd As Integer: fragmentEnd = Len(strClipText) strClipText = strClipText + post Dim endHTML As Integer: endHTML = Len(strClipText) strClipText = Replace(strClipText, "<<<<<<<1", startHTML) strClipText = Replace(strClipText, "<<<<<<<2", endHTML) strClipText = Replace(strClipText, "<<<<<<<3", fragmentStart) strClipText = Replace(strClipText, "<<<<<<<4", fragmentEnd) Dim nCFHTML As Long: nCFHTML = RegisterClipboardFormat("HTML Format") Dim oData As DataObject Set oData = New DataObject oData.Clear oData.SetText StrConv(strClipText, vbFromUnicode), nCFHTML oData.PutInClipboard Debug.Print "Writing to:" & ActiveProject.FullName + ".htm" fnum = FreeFile() Open ActiveProject.FullName + ".htm" für Output As fnum Write #fnum, strReport Close #fnum End Sub Function encodehtml(strInput As String) As String Dim strtemp strtemp = strInput strtemp = Replace(strtemp, Chr(9), "") strtemp = Replace(strtemp, Chr(11), "
") strtemp = Replace(strtemp, Chr(38), "&") strtemp = Replace(strtemp, Chr(160), " ") strtemp = Replace(strtemp, Chr(161), "¡") strtemp = Replace(strtemp, Chr(162), "¢") strtemp = Replace(strtemp, Chr(163), "£") strtemp = Replace(strtemp, Chr(164), "¤") strtemp = Replace(strtemp, Chr(165), "¥") strtemp = Replace(strtemp, Chr(166), "¦") strtemp = Replace(strtemp, Chr(167), "§") strtemp = Replace(strtemp, Chr(168), "ü") strtemp = Replace(strtemp, Chr(169), "©") strtemp = Replace(strtemp, Chr(170), "ª") strtemp = Replace(strtemp, Chr(171), "«") strtemp = Replace(strtemp, Chr(172), "¬") strtemp = Replace(strtemp, Chr(173), "­") strtemp = Replace(strtemp, Chr(174), "®") strtemp = Replace(strtemp, Chr(175), "¯") strtemp = Replace(strtemp, Chr(176), "°") strtemp = Replace(strtemp, Chr(177), "±") strtemp = Replace(strtemp, Chr(178), "²") strtemp = Replace(strtemp, Chr(179), "³") strtemp = Replace(strtemp, Chr(180), "´") strtemp = Replace(strtemp, Chr(181), "µ") strtemp = Replace(strtemp, Chr(182), "¶") strtemp = Replace(strtemp, Chr(183), "·") strtemp = Replace(strtemp, Chr(183), "¸") strtemp = Replace(strtemp, Chr(185), "¹") strtemp = Replace(strtemp, Chr(186), "º") strtemp = Replace(strtemp, Chr(187), "»") strtemp = Replace(strtemp, Chr(188), "¼") strtemp = Replace(strtemp, Chr(189), "½") strtemp = Replace(strtemp, Chr(190), "¾") strtemp = Replace(strtemp, Chr(191), "¿") strtemp = Replace(strtemp, Chr(192), "À") strtemp = Replace(strtemp, Chr(193), "Á") strtemp = Replace(strtemp, Chr(194), "Â") strtemp = Replace(strtemp, Chr(195), "Ã") strtemp = Replace(strtemp, Chr(196), "Ä") strtemp = Replace(strtemp, Chr(197), "Å") strtemp = Replace(strtemp, Chr(198), "Æ") strtemp = Replace(strtemp, Chr(199), "Ç") strtemp = Replace(strtemp, Chr(200), "È") strtemp = Replace(strtemp, Chr(201), "É") strtemp = Replace(strtemp, Chr(202), "Ê") strtemp = Replace(strtemp, Chr(203), "Ë") strtemp = Replace(strtemp, Chr(204), "Ì") strtemp = Replace(strtemp, Chr(205), "Í") strtemp = Replace(strtemp, Chr(206), "Î") strtemp = Replace(strtemp, Chr(207), "Ï") strtemp = Replace(strtemp, Chr(208), "Ð") strtemp = Replace(strtemp, Chr(209), "Ñ") strtemp = Replace(strtemp, Chr(210), "Ò") strtemp = Replace(strtemp, Chr(211), "Ó") strtemp = Replace(strtemp, Chr(212), "Ô") strtemp = Replace(strtemp, Chr(213), "Õ") strtemp = Replace(strtemp, Chr(214), "Ö") strtemp = Replace(strtemp, Chr(215), "×") strtemp = Replace(strtemp, Chr(216), "Ø") strtemp = Replace(strtemp, Chr(217), "Ù") strtemp = Replace(strtemp, Chr(218), "Ú") strtemp = Replace(strtemp, Chr(219), "Û") strtemp = Replace(strtemp, Chr(220), "Ü") strtemp = Replace(strtemp, Chr(221), "Ý") strtemp = Replace(strtemp, Chr(222), "Þ") strtemp = Replace(strtemp, Chr(223), "ß") strtemp = Replace(strtemp, Chr(224), "à") strtemp = Replace(strtemp, Chr(225), "á") strtemp = Replace(strtemp, Chr(226), "â") strtemp = Replace(strtemp, Chr(227), "ã") strtemp = Replace(strtemp, Chr(228), "ä") strtemp = Replace(strtemp, Chr(229), "å") strtemp = Replace(strtemp, Chr(230), "æ") strtemp = Replace(strtemp, Chr(231), "ç") strtemp = Replace(strtemp, Chr(232), "è") strtemp = Replace(strtemp, Chr(233), "é") strtemp = Replace(strtemp, Chr(234), "ê") strtemp = Replace(strtemp, Chr(235), "ë") strtemp = Replace(strtemp, Chr(236), "ì") strtemp = Replace(strtemp, Chr(237), "í") strtemp = Replace(strtemp, Chr(238), "î") strtemp = Replace(strtemp, Chr(239), "ï") strtemp = Replace(strtemp, Chr(240), "ð") strtemp = Replace(strtemp, Chr(241), "ñ") strtemp = Replace(strtemp, Chr(242), "ò") strtemp = Replace(strtemp, Chr(243), "ó") strtemp = Replace(strtemp, Chr(244), "ô") strtemp = Replace(strtemp, Chr(245), "õ") strtemp = Replace(strtemp, Chr(246), "ö") strtemp = Replace(strtemp, Chr(247), "÷") strtemp = Replace(strtemp, Chr(248), "ø") strtemp = Replace(strtemp, Chr(249), "ù") strtemp = Replace(strtemp, Chr(250), "ú") strtemp = Replace(strtemp, Chr(251), "û") strtemp = Replace(strtemp, Chr(252), "ü") strtemp = Replace(strtemp, Chr(253), "ý") strtemp = Replace(strtemp, Chr(254), "þ") strtemp = Replace(strtemp, Chr(255), "ÿ") encodehtml = strtemp End Function