Wikidot Community

'Attribute VB_Name = "Wikidot"
Option Explicit

Private Const vbPicTypeBitmap = 1

Private Type IID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PictDesc
    Size As Long
    Type As Long
        hBmp As Long
        hPal As Long
        Reserved As Long
    End Type

     '''Windows API Function Declarations
#If VBA7 Then
    'Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
'    Private Declare PtrSafe Function OleCreatePictureIndirect Lib _
'    "olepro32.dll" _
'    (PicDesc As PictDesc, RefIID As IID, _
'    ByVal fPictureOwnsHandle As LongPtr, _
'    IPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib _
    "oleaut32.dll" _
    (PicDesc As PictDesc, RefIID As IID, _
    ByVal fPictureOwnsHandle As LongPtr, _
    IPic As IPicture) As Long
    '
    Private Declare PtrSafe Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As LongPtr) As LongPtr
     'Does the clipboard contain a bitmap/metafile?
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As LongPtr
     'Open the clipboard to read
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
     'Get a pointer to the bitmap/metafile
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As LongPtr
     'Close the clipboard
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
     'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
    Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
     'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
    Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As LongPtr, ByVal n1 As LongPtr, ByVal n2 As LongPtr, ByVal un2 As LongPtr) As LongPtr
#Else
    'Private Declare Sub Sleep Lib "kernel32" (ByVal ms as Long)
    Private Declare Function OleCreatePictureIndirect Lib _
    "olepro32.dll" _
    (PicDesc As PictDesc, RefIID As IID, _
    ByVal fPictureOwnsHandle As Long, _
    IPic As IPicture) As Long
    '
    Private Declare Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long
     'Does the clipboard contain a bitmap/metafile?
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal    wFormat As Integer) As Long
     'Open the clipboard to read
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long)    As Long
     'Get a pointer to the bitmap/metafile
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As    Integer) As Long
     'Close the clipboard
    Private Declare Function CloseClipboard Lib "user32" () As Long
     'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
    Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
     'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
    Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
#End If

     'The API format types we're interested in
    Const CF_BITMAP = 2
    Const CF_PALETTE = 9
    Const CF_ENHMETAFILE = 14
    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
     ' Addded by SL Apr/2000
    Const xlPicture = CF_BITMAP
    Const xlBitmap = CF_BITMAP
'i think this is a leftover that i created.
'Private Const vbCFBitmap = 2

Sub Word2Wiki()

    Application.ScreenUpdating = False

    'Heading 1 to Heading 5
    ConvertParagraphStyle wdStyleHeading1, "+ ", ""
    ConvertParagraphStyle wdStyleHeading2, "++ ", ""
    ConvertParagraphStyle wdStyleHeading3, "+++ ", ""
    ConvertParagraphStyle wdStyleHeading4, "++++ ", ""
    ConvertParagraphStyle wdStyleHeading5, "+++++ ", ""

    ConvertItalic       'italic to //
    ConvertBold         'bold to **
    ConvertUnderline    'underline to __
    ConvertImages       '[[image image(x).jpg]]
    ConvertLists        'bullet to *
    ConvertTables       'Cell to ||

    ' Copy to clipboard
    ActiveDocument.Content.Copy

    Application.ScreenUpdating = True
End Sub

Private Sub ConvertParagraphStyle(styleToReplace As WdBuiltinStyle, _
                                    preText As String, _
                                    postText As String)
    Dim normalStyle As Style
    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)

    ActiveDocument.Select

    With Selection.Find

        .ClearFormatting
        .Style = ActiveDocument.Styles(styleToReplace)
        .Text = ""

        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        .Forward = True
        .Wrap = wdFindContinue

        Do While .Execute
            With Selection
                If InStr(1, .Text, vbCr) Then
                    ' Just process the chunk before any newline characters
                    ' We'll pick-up the rest with the next search
                    .Collapse
                    .MoveEndUntil vbCr
                End If

                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    .InsertBefore preText
                    .InsertAfter postText
                End If

                .Style = normalStyle
            End With
        Loop
    End With
End Sub

Private Sub ConvertBold()
    ActiveDocument.Select

    With Selection.Find

        .ClearFormatting
        .Font.Bold = True
        .Text = ""

        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        .Forward = True
        .Wrap = wdFindContinue

        Do While .Execute
            With Selection
                If InStr(1, .Text, vbCr) Then
                    ' Just process the chunk before any newline characters
                    ' We'll pick-up the rest with the next search
                    .Font.Bold = False
                    .Collapse
                    .MoveEndUntil vbCr
                End If

                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    If .Characters.Last = " " Then .End = .End - 1 'If a space is the last character, insert text before it
                    If .Characters.First = " " Then .Start = .Start + 1 'If a space is the first character, insert text after it
                    .Font.Bold = False
                    .InsertBefore "**"
                    .InsertAfter "**"
                End If
                .Font.Bold = False
            End With
        Loop
    End With
End Sub

Private Sub ConvertItalic()
    ActiveDocument.Select

    With Selection.Find

        .ClearFormatting
        .Font.Italic = True
        .Text = ""

        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        .Forward = True
        .Wrap = wdFindContinue

        Do While .Execute
            With Selection
                If InStr(1, .Text, vbCr) Then
                    ' Just process the chunk before any newline characters
                    ' We'll pick-up the rest with the next search
                    .Font.Italic = False
                    .Collapse
                    .MoveEndUntil vbCr
                End If

                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    If .Characters.Last = " " Then .End = .End - 1 'If a space is the last character, insert text before it
                    If .Characters.First = " " Then .Start = .Start + 1 'If a space is the first character, insert text after it
                    .InsertBefore "//"
                    .InsertAfter "//"
                End If
                .Font.Italic = False
            End With
        Loop
    End With
End Sub

Private Sub ConvertUnderline()
    ActiveDocument.Select

    With Selection.Find

        .ClearFormatting
        .Font.Underline = True
        .Text = ""

        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        .Forward = True
        .Wrap = wdFindContinue

        Do While .Execute
            With Selection
                If InStr(1, .Text, vbCr) Then
                    ' Just process the chunk before any newline characters
                    ' We'll pick-up the rest with the next search
                    .Font.Underline = False
                    .Collapse
                    .MoveEndUntil vbCr
                End If

                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    If .Characters.Last = " " Then .End = .End - 1 'If a space is the last character, insert text before it
                    If .Characters.First = " " Then .Start = .Start + 1 'If a space is the first character, insert text after it
                    .InsertBefore "__"
                    .InsertAfter "__"
                End If

                .Font.Underline = False
            End With
        Loop
    End With
End Sub
Private Sub ConvertImages()
    ActiveDocument.Select
    Dim tel As Integer
    Dim Pic As Range
    Dim objPic As IPictureDisp
    'Dim DataObj As MSForms.DataObject
    Dim FName As String
    Dim lngBytes As Long
    Dim hPix As IPicture
    Dim hBitmap As Long
    Dim FolderName As String
    Dim CategoryPrefix As String
    Dim idx As Integer
    Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")

    CategoryPrefix = "TEST"
    FolderName = "%USERPROFILE%\WikiDotMacroPics"
    FolderName = CreateObject("WScript.Shell").ExpandEnvironmentStrings(FolderName)

    tel = 0
    With Selection.Find
        .ClearFormatting
        .Text = "^g"
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        .Forward = True
        .Wrap = wdFindContinue

        Do While .Execute
            With Selection

                'copy the picture to the clipboard
                Call .Range.CopyAsPicture
                'get it back from the clipboard in a way we can deal with it (clever code- not mine)
                hBitmap = CLng(GetClipBoard)
                Set hPix = BitmapToPicture(hBitmap)

                If InStr(1, .Text, vbCr) Then
                    ' Just process the chunk before any newline characters
                    ' We'll pick-up the rest with the next search
                    .Collapse
                    .MoveEndUntil vbCr
                End If
                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    If Not FSO.FolderExists(FolderName) Then
                        'make the folder because it doesn't exist
                        Call FSO.CreateFolder(FolderName)
                    End If

                    tel = tel + 1
                    idx = InStr(Word.ActiveDocument.Name, ".doc")
                    If idx = 0 Then
                        'can't name it properly
                        '.Text = "[[image image(" & tel & ").jpg]]"
                        .Text = "[[image image(" & tel & ").jpg]]"
                        .Text = .Text & "<could not name image number " & CStr(tel) & " properly during conversion, not saved to folder.>"
                    Else
                        FName = Left(Word.ActiveDocument.Name, idx - 1)
                        FName = Replace(FName, " ", "-") 'eliminate spaces in the name
                        'the '~' is the best we can do to create a category as part of the filename
                        'this is because ':' is not acceptable in a windows filing system :-(
                        FName = CategoryPrefix & "~" & FName & "-Pic" & Format(tel, "000") & ".bmp"
                        .Text = "[[image " & FName & "]]"
                        'save the pic with a good filename
                        SavePicture hPix, FolderName & "\" & FName
                        '
                        'You must now attach these pics to the page - and then they will show up :-)
                        '
                    End If
                End If

                'tidy up
                apiDeleteObject (hBitmap)
                Set hPix = Nothing
            End With
        Loop
    End With

    'tidy up
    Set FSO = Nothing
End Sub

'Private Sub cmdCreateIPicture_Click()
'     ' *********************
'     ' You must set a Reference to:
'     ' "OLE Automation"
'     ' for this function to work.
'     ' Goto the Menu and select
'     ' Tools->References
'     ' Scroll down to:
'     ' Ole Automation
'     ' and click in the check box to select
'     ' this reference.
'
'    Dim lngRet As Long
'    Dim lngBytes As Long
'    Dim hPix As IPicture
'    Dim hBitmap As Long
'     'Dim hPicBox As StdPicture
'
'    Me.OLEBound19.SetFocus
'     'Me.OLEbound19.SizeMode = acOLESizeZoom
'    DoCmd.RunCommand acCmdCopy
'    hBitmap = GetClipBoard
'    Set hPix = BitmapToPicture(hBitmap)
'    SavePicture hPix, "C:\ole.bmp"
'    apiDeleteObject (hBitmap)
'    Me.Image0.Picture = "C:\ole.bmp"
'
'    Set hPix = Nothing
'End Sub

Private Sub ConvertLists()
   Dim para As Paragraph
   Dim i As Long
    For Each para In ActiveDocument.ListParagraphs
        With para.Range
        If .ListFormat.ListType = wdListBullet Then
            .InsertBefore "* "
        Else
            .InsertBefore "# "
        End If
            For i = 2 To .ListFormat.ListLevelNumber
                .InsertBefore " "
            Next i
            .ListFormat.RemoveNumbers
        End With
    Next para
End Sub

Private Sub ConvertTables()

    Dim myRange As Word.Range
    Dim tTable  As Word.Table
    Dim tRow    As Word.Row
    Dim tCell   As Word.Cell
    Dim strText As String
    Dim addText As String

    Dim i   As Long
    Dim j   As Long
    Dim k   As Long
    Dim l   As Long
    Dim lenM As Integer

    For Each tTable In ActiveDocument.Tables

            'Memorize table text
            ReDim x(1 To tTable.Rows.Count, 1 To tTable.Columns.Count)
            i = 0
            For Each tRow In tTable.Rows
                i = i + 1
                j = 0
                For Each tCell In tRow.Cells
                    j = j + 1
                    strText = tCell.Range.Text
                    lenM = Len(strText)
                    strText = Left(strText, (lenM - 2))
                    addText = " _" + "[LF] "

                    Do While InStr(1, strText, vbCr)
                        strText = Replace(strText, vbCr, addText)
                    Loop
                    Do While InStr(1, strText, "[LF]")
                       strText = Replace(strText, "[LF]", vbCr)
                    Loop
                   x(i, j) = Left(strText, Len(strText))
                Next tCell
            Next tRow

            'Delete table and position after table
            Set myRange = tTable.Range
            myRange.Collapse Direction:=wdCollapseEnd
            tTable.Delete

            'Rewrite table with memorized text
            myRange.InsertParagraphAfter
            'myRange.InsertAfter ("S|")
            'myRange.InsertParagraphAfter
            For k = 1 To i

                myRange.InsertAfter "|| " + x(k, 1)
                For l = 2 To j
                    myRange.InsertAfter " || " + x(k, l)
                   ' myRange.InsertAfter " |" + x(k, l)
                Next l
                'myRange.InsertParagraphAfter
                myRange.InsertAfter " ||"
                myRange.InsertParagraphAfter
            Next k
            'myRange.InsertAfter ("|E")
            'myRange.InsertParagraphAfter

    Next tTable

End Sub

 ' Here's the code behind the code module

     '*******************************************
     'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 VBA ONLY
     '
     'Copyright: Lebans Holdings 1999 Ltd.
     '           May not be resold in whole or part. Please feel
     '           free to use any/all of this code within your
     '           own application without cost or obligation.
     '           Please include the one line Copyright notice
     '           if you use this function in your own code.
     '
     'Name:      BitmapToPicture &
     '           GetClipBoard
     '
     'Purpose:   Provides a method to save the contents of a
     '           Bound or Unbound OLE Control to a Disk file.
     '           This version only handles BITMAP files.
     '           '
     'Author:    Stephen Lebans
     'Email:     Step...@lebans.com
     'Web Site:  www.lebans.com
     'Date:      Apr 10, 2000, 05:31:18 AM
     '
     'Called by: Any
     '
     'Inputs:    Needs a Handle to a Bitmap.
     '           This must be a 24 bit bitmap for this release.
     '
     'Credits:
     'As noted directly in Source :-)
     '
     'BUGS:
     'To keep it simple this version only works with Bitmap files of 16 Or 24 bits.
     'I'll go back and add the
     'code to allow any depth bitmaps and add support for
     'metafiles as well.
     'No serious bugs notices at this point in time.
     'Please report any bugs to my email address.
     '
     'What's Missing:
     '
     '
     'HOW TO USE:
     '
     '*******************************************

    Private Function BitmapToPicture(ByVal hBmp As Long, _
        Optional ByVal hPal As Long = 0&) _
        As IPicture '

         ' The following code is adapted from
         ' Bruce McKinney's "Hardcore Visual Basic"
         ' And Code samples from:
         ' http://www.mvps.org/vbnet/code/bitmap/printscreenole.htmv
         ' and examples posted on MSDN

         ' The handle to the Bitmap created by CreateDibSection
         ' cannot be passed directly as the PICTDESC.Bitmap element
         ' that get's passed to OleCreatePictureIndirect.
         ' We need to create a regular bitmap from our CreateDibSection
         'Dim hBmptemp As Long, hBmpOrig As Long
         'Dim hDCtemp As Long

         'Fill picture description
        Dim lngRet As Long
        Dim IPic As IPicture, picdes As PictDesc, iidIPicture As IID

         'hDCtemp = apiCreateCompatibleDC(0)
         'hBmptemp = apiCreateCompatibleBitmap _
         '(mhDCImage, lpBmih.bmiHeader.biWidth, _
         'lpBmih.bmiHeader.biHeight)
         '
         'hBmpOrig = apiSelectObject(hDCtemp, hBmptemp)
         '
         '  lngRet = apiBitBlt(hDCtemp, 0&, 0&, lpBmih.bmiHeader.biWidth, _
         '        lpBmih.bmiHeader.biHeight, mhDCImage, 0, 0, SRCCOPY)
         '
         'hBmptemp = apiSelectObject(hDCtemp, hBmpOrig)
         'Call apiDeleteDC(hDCtemp)

        picdes.Size = Len(picdes)
        picdes.Type = vbPicTypeBitmap
        picdes.hBmp = hBmp

         ' No palette info here
         ' Everything is 24bit for now

        picdes.hPal = hPal
         ' ' Fill in magic IPicture GUID         {7BF80980-BF32-101A-8BBB-00AA00300CAB}
        iidIPicture.Data1 = &H7BF80980
        iidIPicture.Data2 = &HBF32
        iidIPicture.Data3 = &H101A
        iidIPicture.Data4(0) = &H8B
        iidIPicture.Data4(1) = &HBB
        iidIPicture.Data4(2) = &H0
        iidIPicture.Data4(3) = &HAA
        iidIPicture.Data4(4) = &H0
        iidIPicture.Data4(5) = &H30
        iidIPicture.Data4(6) = &HC
        iidIPicture.Data4(7) = &HAB
         '' Create picture from bitmap handle
        lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, IPic)
         '' Result will be valid Picture or Nothing-either way set it
        Set BitmapToPicture = IPic
    End Function

    Function GetClipBoard() As LongPtr
         ' Adapted from original Source Code by:
         '* MODULE NAME:     Paste Picture
         '* AUTHOR & DATE:   STEPHEN BULLEN, Business Modelling Solutions Ltd.
         '*                  15 November 1998
         '*
         '* CONTACT:         Step...@BMSLtd.co.uk
         '* WEB SITE:        http://www.BMSLtd.co.uk

         ' Handles for graphic Objects
        Dim hClipBoard As LongPtr
        Dim hBitmap As LongPtr
        Dim hBitmap2 As LongPtr

         'Check if the clipboard contains the required format
         'hPicAvail = IsClipboardFormatAvailable(lPicType)

         ' Open the ClipBoard
        hClipBoard = OpenClipboard(0&)

        If hClipBoard <> 0 Then
             ' Get a handle to the Bitmap
            hBitmap = GetClipboardData(CF_BITMAP)

            If hBitmap = 0 Then GoTo exit_error
             ' Create our own copy of the image on the clipboard, in the
            'appropriate format.
             'If lPicType = CF_BITMAP Then
            hBitmap2 = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
             '   Else
             '  hBitmap2 = CopyEnhMetaFile(hBitmap, vbNullString)
             ' End If

             'Release the clipboard to other programs
            hClipBoard = CloseClipboard

            GetClipBoard = hBitmap2
            Exit Function

        End If

exit_error:
         ' Return False
        GetClipBoard = -1
    End Function