Wikipedia:Archiv/Textverarbeitung/Word2Wiki

aus Wikipedia, der freien Enzyklopädie
Zur Navigation springen Zur Suche springen

Diese Seite gehört zum Wikipedia-Archiv.

The contents of this page have moved to: Word2MediaWikiPlus

This is outdated.

Installation and download

[Quelltext bearbeiten]

Below you will find the code of the several basic modules and classes. If you do not want the image converter, you only need the Word2Wiki Module.

  1. Download the files. (This download is not outdated, it contains a newer version.)
  2. Go into the Visual Basic Editor
  3. Create a module: Word2Wiki
    1. Copy the code into the module
  4. For the image converter
    1. Create a module: modEnumMetafile
    2. Create a class: cDIBSection
    3. Create a class: clsCommonDialog

Module: Word2Wiki

[Quelltext bearbeiten]

'Word2Wiki-Converter V0.3
'Works only with Word 2000 and above
'If you use Word97 you need to get rid of the image converter and change some ^p

'Changes:
'-general: added some const to customize this
'-general: added hourglass and statustext
'-text: added text color
'-tables: added blank space in empty cells
'-tables: added alignment of text
'-tables: added tableformat string, const TableTemplate
'-hyperlinks: redesign: changed html and file-links, others will not be converted
'-images: added function to save all pictures of the document as .bmp and replace with Image-Tag
'-paragraph spacing: added manual line break and MediaWiki-like paragraphs
'-cleanup-function

'ToDo:
'- tables: background colors, merged cells, merged rows, title row, title column
'- images: convert floating images
'- images: Make something different with included documents
'- lists: nested lists


'Global Const
Const UpdateScreen As Boolean = True 'Set to false to make the macro quicker, but then you do not see anything...
Const UnableToConvertMarker$ = "### Error converting ###: "
Const HeaderFirstLevel$ = "==" 'Use "=" if you like, but not recommended by MediaWiki
'Const TableTemplate$ = "{{Prettytable}}"
Const TableTemplate$ = "border=""2"" cellspacing=""0"" cellpadding=""4"""
'Const TableTemplate = "{{Tabelle-Kopf}}"
Const NewParagraphWithBR As Boolean = False 'false: Make two Paragraphs, true: use <br> (true not tested)
Const ImageFormat = "jpg" '"bmp" 'Note: Images will always be saved as bmp, but if you use an image converter (like IrfanView) to mass convert to jpg, the [Image:..] tags will have the correct ending in it

Declare Function OleTranslateColor Lib "oleaut32.dll" _
    (ByVal lOleColor As Long, ByVal lHPalette As Long, _
    ByRef lColorRef As Long) As Long

Sub Word2MediaWiki()
   
    'Main Procedure for converting
       
    Application.ScreenUpdating = UpdateScreen
    System.Cursor = wdCursorWait
    StatusBar = "Converting your document..."
    DoEvents
    
    'All conversions
    MediaWikiConvertPrepare
    ReplaceQuotes
    MediaWikiEscapeChars
    MediaWikiConvertHyperlinks
    MediaWikiConvertH1
    MediaWikiConvertH2
    MediaWikiConvertH3
    MediaWikiConvertH4
    MediaWikiConvertH5
    MediaWikiConvertItalic
    MediaWikiConvertBold
    MediaWikiConvertUnderline
    MediaWikiConvertStrikeThrough
    MediaWikiConvertSuperscript
    MediaWikiConvertSubscript
    MediaWikiConvertLists
    MediaWikiConvertColorsText
    MediaWikiConvertTables
    MediaWikiConvertParagraphs
    MediaWikiConvertImages
    MediaWikiCleanUp

    ActiveDocument.Content.Copy ' Copy to clipboard
    Application.ScreenUpdating = True
    System.Cursor = wdCursorNormal
    StatusBar = "Converting finished!"

End Sub

Sub Test()

    

End Sub

Sub EditPasteObject()
'Unused: needed for floating images!
On Error GoTo ErrHandler ' Error will occur if object is Office Art.
      
    ActiveWindow.View.Type = wdPageView
    Selection.PasteSpecial Placement:=wdInLine
    ' If the object is not text, then convert it.
    If Selection.Type = wdSelectionShape Then
         Selection.ShapeRange.ConvertToInlineShape
    End If

ErrHandler:
    If Err <> 0 Then
        ' If the object is Office Art, paste it as an inline picture
        ActiveDocument.Undo
        Selection.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=wdInLine
    End If

End Sub


Private Sub PrintAscW()
   
    Debug.Print AscW(Selection.Text)
    Debug.Print Selection.Font.Name
   
End Sub

Private Sub MediaWikiCleanUp()

    'remove all empty paragraphs at end of document
    Selection.EndKey Unit:=wdStory
    Do
        Selection.MoveLeft wdCharacter, 1, wdExtend
        If Selection.Text = Chr(13) Then
            Selection.Delete
        Else
            Exit Do
        End If
    Loop
    
    'remove blanks at begin and end of paragraph
    'maybe there is a faster method?
    Dim pg As Paragraph, l&
    For Each pg In ActiveDocument.Paragraphs
        'blanks at the beginning
        Do While Left$(pg.Range.Text, 1) = " "
            pg.Range.Select
            Selection.Collapse wdCollapseStart
            Selection.Delete
        Loop
    Next

    'blanks at the end
    Do
        ReplaceString " ^p", "^p"
        'nothing
    Loop Until Not FindString(" ^p")
    

End Sub

Private Sub MediaWikiConvertBold()
   
    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 Len(.Text) > 1 And 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 "'''"
                    .InsertAfter "'''"
                End If

                '.Style = ActiveDocument.Styles("Default Paragraph Font")
                .Font.Bold = False

            End With
        Loop

    End With

End Sub

Sub MediaWikiConvertColorsText()
    'converts the colors of the text to HTML-Colors
    'maybe there is a faster method?
    
    Dim CurColor& 'Current Color, indicates change
    Dim OpenColor& 'Color the font was opened with
    Dim pgColor&
    Dim cNo& 'Number of characters
    Dim txt$
    Dim FontOpen As Boolean
    Dim pg As Paragraph
    
    'First check, if the paragraphs have different colors
    'seems Word gives 9999999 if more than one color!
    
    For Each pg In ActiveDocument.Paragraphs
        'blanks at the beginning
        If pgColor <> pg.Range.Font.Color Then
            pgColor = pg.Range.Font.Color
            If pgColor = "9999999" Then 'different colors in paragraph
                'Check each letter in paragraph
                'I found no other possibility other then to check each letter
                'Dead slow
                cNo = 0
                With pg.Range
                Do While cNo < .Characters.Count
                    cNo = cNo + 1
                    'Debug.Print cNo, .Characters(cNo)
                    If cNo Mod 20 = 0 Then DoEvents
                    If cNo Mod 100 = 0 Then Debug.Print cNo
                    If CurColor <> .Characters(cNo).Font.Color Then
                        If FontOpen = False Then
                            'open font
                            CurColor = .Characters(cNo).Font.Color
                            If RGB2HTML(CurColor) <> "#000000" Then
                                OpenColor = .Characters(cNo).Font.Color
                                txt = "<font color=""" & RGB2HTML(OpenColor) & """>"
                                .Characters(cNo).InsertBefore txt
                                FontOpen = True
                                cNo = cNo + Len(txt) - 1
                            End If
                        Else
                            'close font
                            CurColor = 0
                            OpenColor = 0
                            txt = "</font>"
                            .Characters(cNo).InsertBefore txt
                            FontOpen = False
                            cNo = cNo + Len(txt) - 1
                        End If
                    End If
                Loop
                End With
                
            ElseIf FontOpen = False Then
                    'open font
                    pgColor = pg.Range.Font.Color
                    If RGB2HTML(pgColor) <> "#000000" Then
                        OpenColor = pg.Range.Font.Color
                        txt = "<font color=""" & RGB2HTML(OpenColor) & """>"
                        pg.Range.InsertBefore txt
                        FontOpen = True
                        cNo = cNo + Len(txt) - 1
                    End If
                Else
                    'close font
                    If pgColor <> OpenColor Then
                        CurColor = 0
                        OpenColor = 0
                        txt = "</font>"
                        pg.Range.InsertBefore txt
                        FontOpen = False
                        cNo = cNo + Len(txt) - 1
                    End If
                'End If
            End If
            
        End If
    Next
    
End Sub

Private Sub MediaWikiConvertH1()
    ReplaceHeading wdStyleHeading1, HeaderFirstLevel
End Sub

Private Sub MediaWikiConvertH2()
    ReplaceHeading wdStyleHeading2, HeaderFirstLevel & "="
End Sub

Private Sub MediaWikiConvertH3()
    ReplaceHeading wdStyleHeading3, HeaderFirstLevel & "=="
End Sub

Private Sub MediaWikiConvertH4()
    ReplaceHeading wdStyleHeading4, HeaderFirstLevel & "==="
End Sub

Private Sub MediaWikiConvertH5()
    ReplaceHeading wdStyleHeading5, HeaderFirstLevel & "===="
End Sub

Private Sub MediaWikiConvertHyperlinks()
    'converts Hyperlinks
    '24-MAY-2006: only convert http..., mark others with error marker
   
   
    Dim hyperCount&
    Dim i&
    Dim addr$ ', title$

    hyperCount = ActiveDocument.Hyperlinks.Count

    For i = 1 To hyperCount

        With ActiveDocument.Hyperlinks(1) 'must be 1, since the delete changes count and position

            addr = .Address
            If Trim$(addr) = "" Then addr = "no hyperlink found"
            'title = .Range.Text
           
            'Link and name of http
            If LCase(Left$(addr, 4)) = "http" Or LCase(Left$(addr, 3)) = "ftp" Then
                .Delete
                .Range.InsertBefore "[" & addr & " "
                .Range.InsertAfter "]"
               
                GoTo MediaWikiConvertHyperlinks_Next
            End If
           
            'file guess
            If Len(addr) > 4 Then 'the reason for not nice goto
                If Mid$(addr, Len(addr) - 3, 1) = "." Then
                    .Delete
                    .Range.InsertBefore "[file://" & addr & " "
                    .Range.InsertAfter "]"
                   
                    GoTo MediaWikiConvertHyperlinks_Next
                End If
            End If
           
            'unidentified
            .Delete
            .Range.InsertBefore UnableToConvertMarker & "[" & addr & " "
            .Range.InsertAfter "]"

MediaWikiConvertHyperlinks_Next:
        End With

    Next i

End Sub

Private Sub MediaWikiConvertImages()
    'Saves all images to disk in bmp-Format
    'Change ImageFormat for other ending in [Image:]-Tag
    'Note: Images will always be saved as bmp, but if you use an image converter (like IrfanView) to mass convert to jpg, the [Image:..] tags will have the correct ending in it
    
    Dim myIS As InlineShape
    Dim DocTitle$, ImagePathName$
    Dim PicNo&, p&
    
    DocTitle = ActiveDocument.Name
    p = InStr(1, DocTitle, ".")
    If p > 0 Then DocTitle = Left$(DocTitle, p - 1)
    DocTitle = DocTitle & "_"
    
    For Each myIS In ActiveDocument.InlineShapes
        myIS.Select
        PicNo = PicNo + 1
        ImagePathName = FormatPfad(ActiveDocument.Path) & DocTitle & PicNo & ".bmp"
        Selection.InsertAfter "[[Image:" & DocTitle & PicNo & "." & ImageFormat & "]]"
        myIS.Select
        Call SaveClipBoardToBitmap(ImagePathName)
        Selection.Delete
        Selection.MoveRight wdCharacter, 1, wdExtend
        If Selection.Text = " " Then Selection.Collapse: Selection.Delete
    Next myIS

End Sub

Private Sub MediaWikiConvertItalic()

    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 Len(.Text) > 1 And 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 "''"
                    .InsertAfter "''"
                End If

                '.Style = ActiveDocument.Styles("Default Paragraph Font")
                .Font.Italic = False

            End With
        Loop

    End With

End Sub

Private Sub MediaWikiConvertLists()
    'converts lists
    'ToDo: Will not resume numbers if line break inbetween
    'ToDo: Will not work correctly if list in list

    Dim para As Paragraph

    For Each para In ActiveDocument.ListParagraphs
        With para.Range

            .InsertBefore " "
            For i = 1 To .ListFormat.ListLevelNumber
                If .ListFormat.ListType = wdListBullet Then
                    .InsertBefore "*"
                Else
                    .InsertBefore "#"
                End If
            Next i
            .ListFormat.RemoveNumbers

        End With
    Next para

End Sub

Private Sub MediaWikiConvertParagraphs()
    'converts Paragraphs for better reading in MediaWiki. Otherwise it will resume within the line.

    Dim txt$
    Dim pg As Paragraph
    Dim lH&, jump&
    Dim InTable As Boolean
   
    lH = Len(HeaderFirstLevel)
   
    If NewParagraphWithBR Then
    
        'code not tested!!!
        
        
        'add <br> to all paragraphs
        ReplaceString "^p", "<br>^p"
       
        'That is too much, so now eliminate all wrong <br>
       
        'Headers
        ReplaceString HeaderFirstLevel & "<br>^p", HeaderFirstLevel & "^p"
       
        'Double <br> will be recognized correctly as new line
        ReplaceString "<br>^p<br>^p", "^p^p"
        ReplaceString "<br>^p<br>^p", "^p^p"
        ReplaceString "<br>^p<br>^p", "^p^p"
       
       
        'Further unused coding to clean up
        For Each pg In ActiveDocument.Paragraphs
            With pg
           
                txt = .Range.Text
           
            End With
        Next
       
    Else
        'use two lines
       
        'add <br> to all manual line breaks
        If Left$(Application.Version, 1) = 8 Then
            ReplaceString "^z", "<br>" 'Word '97
        Else
            ReplaceString "^l", "<br>" 'Word 2000
        End If
       
        'Add empty line at document end to prevent error
        Selection.EndKey Unit:=wdStory
        Selection.InsertAfter Chr(13)
       
        For Each pg In ActiveDocument.Paragraphs
            With pg
           
                If jump = 0 Then
                    If InStr(1, .Range.Text, "{|") > 0 Then InTable = True
                    If InStr(1, .Range.Text, "|}") > 0 Then InTable = False
               
                    If InTable = False Then
                        If Asc(.Range.Text) = 13 Then
                            'Paragraph empty?
                            'nothing
                            'goto next paragraph
                        ElseIf Left$(.Range.Text, 1) = "*" Or Left$(.Range.Text, 1) = "#" Then
                            'List?
                            'nothing
                            'goto next paragraph
                        ElseIf Left$(.Range.Text, lH) = HeaderFirstLevel Then
                            'Header?
                            'nothing
                            'jump = 1
                            'goto next paragraph
                        ElseIf Asc(.Next.Range.Text) = 13 Then
                            'Next Paragraph empty?
                            'nothing
                            'goto next paragraph
                        ElseIf right$(.Range.Text, 5) = "<br>" & Chr(13) Then
                            'manual line break?
                            'nothing
                            'goto next paragraph
                        Else
                            .Range.InsertAfter Chr(13)
                            txt = .Range.Text 'Debug Info
                        End If
                    End If
               
                Else
                    jump = jump - 1
                End If
           
            End With
        Next
       
    End If

End Sub

Sub MediaWikiConvertPrepare()

    'Delete TOC as MediaWiki makes it itself
    Dim x As Document
    Set x = ActiveDocument
    
    Dim f As Field
    For Each f In ActiveDocument.Fields
        If f.Type = wdFieldTOC Then
            f.Delete
        End If
    Next

    ' Delete all manual pagebreaks, must be at beginning of macro (problems with headers)
    ReplaceString "^m", ""

End Sub

Private Sub MediaWikiConvertStrikeThrough()

    ActiveDocument.Select
    With Selection.Find

        .ClearFormatting
        .Font.StrikeThrough = True
        .Text = ""
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Forward = True
        .Wrap = wdFindContinue

        Do While .Execute
            With Selection

                If Len(.Text) > 1 And 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 "-"
                    .InsertAfter "-"
                End If

                '.Style = ActiveDocument.Styles("Default Paragraph Font")
                .Font.StrikeThrough = False

            End With
        Loop

    End With

End Sub

 

Private Sub MediaWikiConvertSubscript()

    ActiveDocument.Select
    With Selection.Find

        .ClearFormatting
        .Font.Subscript = True
        .Text = ""
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Forward = True
        .Wrap = wdFindContinue

        Do While .Execute
            With Selection

                .Text = Trim(.Text)
                If Len(.Text) > 1 And 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 "~"
                    .InsertAfter "~"
                End If

                .Style = ActiveDocument.Styles("Default Paragraph Font")
                .Font.Subscript = False
            End With
        Loop

    End With

End Sub

Private Sub MediaWikiConvertSuperscript()

    ActiveDocument.Select
    With Selection.Find

        .ClearFormatting
        .Font.Superscript = True
        .Text = ""
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Forward = True
        .Wrap = wdFindContinue
       
        Do While .Execute
            With Selection

                .Text = Trim(.Text)
                If Len(.Text) > 1 And 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 "^"
                    .InsertAfter "^"
                End If

                .Style = ActiveDocument.Styles("Default Paragraph Font")
                .Font.Superscript = False

            End With
        Loop

    End With

End Sub

Private Sub MediaWikiConvertTables()
    'converts tables
    '24-MAY-2006: added TableTemplate
    '24-MAY-2006: added Blank space for blank cells
    'ToDo: Background colours
    'ToDo: merged cells
   
    Dim thisTable As Table
    Dim cRow&

    For Each thisTable In ActiveDocument.Tables
        cRow = 0
        With thisTable

            For Each arow In thisTable.Rows
                cRow = cRow + 1
                Debug.Print "row: "; cRow & " cells: " & arow.Cells.Count
                With arow


                    For Each acell In arow.Cells
                        With acell
                            
                            'add blank space in empty cells
                            If Trim$(acell.Range.Text) = Chr(13) & Chr(7) Then
                                acell.Range.InsertBefore " "
                            End If
                            
                            
                            'Paragraph orientation: check first paragraph and accept center and right
                            acell.Select
                            Select Case acell.Range.Paragraphs(1).Alignment
                                Case wdAlignParagraphCenter
                                    acell.Range.InsertBefore "<center>"
                                    acell.Range.InsertAfter "</center>"
                                    
                                Case wdAlignParagraphRight
                                    acell.Range.InsertBefore "align = ""right""|"
                                    'acell.Range.InsertAfter "</right>"
                            
                                Case wdAlignParagraphJustify
                                    acell.Range.InsertBefore "<justify>"
                                    acell.Range.InsertAfter "</justify>"
                            
                            End Select
                            
                            'Divider
                            acell.Range.InsertBefore "|"
                            
                        End With
                    Next acell
                    .Range.InsertAfter vbCrLf + "|-"

                End With
            Next arow

            .Range.InsertBefore "{|" & TableTemplate & vbCrLf
            .Range.InsertAfter vbCrLf & "|}"
            .ConvertToText "|"

        End With
    Next thisTable

End Sub

Private Sub MediaWikiConvertUnderline()

    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 Len(.Text) > 1 And 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 "<u>"
                    .InsertAfter "</u>"
                End If

                ' .Style = ActiveDocument.Styles("Default Paragraph Font")
                .Font.Underline = False
            End With
        Loop

    End With

End Sub

Private Sub ReplaceQuotes()
    ' Replace all smart quotes with their dumb equivalents

    Dim quotes As Boolean

    quotes = Options.AutoFormatAsYouTypeReplaceQuotes
    Options.AutoFormatAsYouTypeReplaceQuotes = False

    ReplaceString ChrW(8220), """"
    ReplaceString ChrW(8221), """"
    ReplaceString "‘", "'"
    ReplaceString "’", "'"

    Options.AutoFormatAsYouTypeReplaceQuotes = quotes

End Sub

Private Sub MediaWikiEscapeChars()

    EscapeCharacter "*"
    EscapeCharacter "#"
    'EscapeCharacter "_"
    'EscapeCharacter "-"
    'EscapeCharacter "+"
    EscapeCharacter "{"
    EscapeCharacter "}"
    EscapeCharacter "["
    EscapeCharacter "]"
    EscapeCharacter "~"
    EscapeCharacter "^^"
    EscapeCharacter "|"
    EscapeCharacter "'"

End Sub

Private Function ReplaceHeading(styleHeading As String, headerPrefix As String)
    'replaces Heading with Wiki-Heading, "=" for first Level
   
    Dim normalStyle As Style

    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)

    ActiveDocument.Select
    With Selection.Find

        .ClearFormatting
        .Style = ActiveDocument.Styles(styleHeading)
        .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 headerPrefix
                    .InsertBefore vbCr
                    .InsertAfter headerPrefix
                End If
                .Style = normalStyle
            End With
        Loop
       
    End With
End Function

Private Function EscapeCharacter(char As String)
    'replaces one specific Character in whole document
    'ReplaceString char, "\" & char 'old style
    ReplaceString char, "" & char & ""
End Function

Private Function ReplaceString(findStr As String, replacementStr As String)
    'replaces text in the whole document (replace all)
   
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = findStr
        .Replacement.Text = replacementStr
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Function

Private Function FindString(findStr As String) As Boolean
    'finds text in the whole document
    'returns true if text was found
   
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = findStr
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    FindString = Selection.Find.Execute
End Function

Public Function RGB2HTML(ByVal RGBColor As Long) As String
'http://www.aboutvb.de/khw/artikel/khwrgbhtml.htm
    Dim nRGBHex As String
    
    nRGBHex = right$("000000" & Hex$(OleConvertColor(RGBColor)), 6)
    RGB2HTML = "#" & right$(nRGBHex, 2) & Mid$(nRGBHex, 3, 2) & Left$(nRGBHex, 2)

End Function

Public Function OleConvertColor(ByVal Color As Long) As Long
  Dim nColor As Long
  
  OleTranslateColor Color, 0&, nColor
  OleConvertColor = nColor
End Function


Module: modEnumMetafile

[Quelltext bearbeiten]

Option Explicit
Private Type RECT
    Left As Long
    top As Long
    right As Long
    Bottom As Long
End Type

Private Type emr
        iType As Long
        nSize As Long
End Type

Private Type ENHMETARECORD
        iType As Long
        nSize As Long
        dParm(1) As Long
End Type
Private Type HANDLETABLE
        objectHandle(1) As Long
End Type
Private Type EMRSTRETCHDIBITS
        pEmr As emr
        rclBounds As RECT
        xDest As Long
        yDest As Long
        xSrc As Long
        ySrc As Long
        cxSrc As Long
        cySrc As Long
        offBmiSrc As Long
        cbBmiSrc As Long
        offBitsSrc As Long
        cbBitsSrc As Long
        iUsageSrc As Long
        dwRop As Long
        cxDest As Long
        cyDest As Long
End Type
   Private Const EMR_GDICOMMENT = 70
Private Const EMR_STRETCHDIBITS = 81
        
Private Declare Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
    
Private Declare Function EnumEnhMetaFile Lib "gdi32" _
(ByVal hDC As Long, ByVal hEMF As Long, ByVal lpEnhMetaFunc As Long, _
lpData As Any, lpRect As RECT) As Long

Private Declare Function GetFileAttributesA Lib "kernel32" (ByVal lpFileName As String) As Long
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10&
Private Const FILE_ATTRIBUTE_INVALID   As Long = -1&  ' = &HFFFFFFFF&

Private Declare Function PlayEnhMetaFileRecord Lib "gdi32" _
(ByVal hDC As Long, lpHandletable As HANDLETABLE, _
lpEnhMetaRecord As ENHMETARECORD, ByVal nHandles As Long) As Long
       
Public Function DirExists(sPathName) As Boolean
' -------------------------------------------------------------------
' Funktion: Prüft, ob Verzeichnis existiert
'
' Parameter: Pfad
'
' Rückgabewerte: wahr, wenn existent
'
' Aufgerufene Prozeduren: GetFileAttributesA
'
' letzte Änderung: 26.05.2002
' -------------------------------------------------------------------
    Dim attr As Long

    attr = GetFileAttributesA(sPathName)

    DirExists = Not (attr = FILE_ATTRIBUTE_INVALID)
    'Originalcode
    'If (attr = FILE_ATTRIBUTE_INVALID) Then
    '    DirExists = False
    'Else
    '    DirExists = ((attr And FILE_ATTRIBUTE_DIRECTORY) > 0)
    'End If
End Function

Public Function GetDateiPfad(ByVal Pfad As String) As String
'ermittelt aus Verzeichnis & Datei das Verzeichnis
'erstellt 12.09.00
On Error Resume Next
    
    Dim p As Integer
    
    p = 0
    Do
        p = InStr(p + 1, Pfad, "\")
        If p > 0 Then GetDateiPfad = Left(Pfad, p) Else Exit Do
    Loop
    
End Function

Function FormatPfad(ByVal Pfad As Variant) As String
' -------------------------------------------------------------------
' Funktion: Gibt Pfad so aus, dass immer ein "\" am Ende steht
'
' Parameter: Pfad
'
' Rückgabewerte: vollständiger Pfad
'
' letzte Änderung: 18.03.2006
' -------------------------------------------------------------------
    
    
    FormatPfad = IIf(right$(Pfad, 1) = "\", Pfad, Pfad & "\")
    'If Right$(Pfad, 1) <> "\" Then Pfad = Pfad + "\"
    'FormatPfad = Pfad

End Function

Public Function SaveClipBoardToBitmap(Optional ByVal FilePathName$ = "") As Boolean
    Dim sName As String
    Dim blRet As Boolean
    Dim lngRet As Long
    
    
    ' Our DIBSection class
    Dim cDib As New cDIBSection
    
    ' Let's copy the currently selected object to the Clipboard
    ActiveDocument.ActiveWindow.Selection.Copy
    DoEvents
    
    ' Call our function that will return a handle to
    ' the Bimtap/Metafile on the ClipBoard
    blRet = cDib.GetClipBoardOLE
    If blRet = False Then
        MsgBox "No Metafile on the ClipBoard"
         SaveClipBoardToBitmap = False
        Exit Function
    End If
    
    ' Copy the Metafile to our DIBSection class
    blRet = cDib.EMFToDIB
    If blRet = False Then
        MsgBox "Unable to Create DIBSECTION"
        SaveClipBoardToBitmap = False
        Exit Function
    End If
    
    'Check FileName
    
    If FilePathName <> "" Then
        If GetDateiPfad(FilePathName) = "" Then FilePathName = FormatPfad(ActiveDocument.Path) & FilePathName
        If Not DirExists(GetDateiPfad(FilePathName)) Then FilePathName = ""
    End If
    
    If FilePathName = "" Then
        sName = cDib.fSaveDialog("Please Enter a Name for the Bitmap File", "BMP")
    Else
        sName = FilePathName
    End If
    If Len(sName & vbNullString) = 0 Then
         SaveClipBoardToBitmap = False
         Exit Function
    End If
    
    ' Save the Image to disk
    cDib.SavePicture sName
    
    ' Release our instance of the class
    Set cDib = Nothing
End Function


Public Function SaveClipboardToMetafile() As Boolean

Dim sName As String
Dim blRet As Boolean
Dim lngRet As Long


' Our DIBSection class
Dim cDib As New cDIBSection

' Let's copy the currently selected object to the Clipboard
ActiveDocument.ActiveWindow.Selection.Copy

DoEvents

' Call our function that will return a handle to
' the Bimtap/Metafile on the ClipBoard
blRet = cDib.GetClipBoardOLE
If blRet = False Then
    MsgBox "No Metafile on the ClipBoard"
    SaveClipboardToMetafile = False
    Exit Function
End If

sName = cDib.fSaveDialog("Please Enter a Name for the Enhanced Metafile", "EMF")
If Len(sName & vbNullString) = 0 Then
    SaveClipboardToMetafile = False
    Exit Function
End If

' Save the EMF to disk
cDib.SaveEMF sName

' Release our instance of the class
Set cDib = Nothing

End Function

' In previous projects I had used the GetMetafileBits calls to
' get at the records of a Metafile. This results in the original metafile
' being embedded within the  returned data as a GDICOMMENT rec. Obviously
' thsi would needlessly bloat the file. I am leaving the code in
' in case another user/developer requires the ability
' to prune out these or other records.
Public Function EnhMetaFileProc(ByVal hDC As Long, _
    ByRef hTable As HANDLETABLE, ByRef EnhMetaRec As ENHMETARECORD, _
    ByVal nHandles As Long, ByVal OptData As Long) As Long

    Dim lRet As Long

    If (EnhMetaRec.iType = EMR_GDICOMMENT) Then
       'Skip this record!!
       lRet = 1
    Else
        lRet = PlayEnhMetaFileRecord(hDC, hTable, EnhMetaRec, ByVal nHandles)
    End If

    EnhMetaFileProc = lRet
End Function

Public Function EnumEMFSkipGDICOMMENT(hEMF As Long, hDC As Long, Width As Long, Height As Long) As Boolean
Dim rcInfo As RECT
Dim rcOutPut As RECT
Dim lRet As Long
    ' Supply dummy values otherwise the GDI will not enumerate the Metafile records.
    rcOutPut.right = Width
    rcOutPut.Bottom = Height
    lRet = EnumEnhMetaFile(hDC, hEMF, AddressOf EnhMetaFileProc, rcInfo, rcOutPut)
End Function


Public Function EnhMetaFileProcInfo(ByVal hDC As Long, _
ByRef hTable As HANDLETABLE, ByRef EnhMetaRec As ENHMETARECORD, _
ByVal nHandles As Long, ByRef OptData As RECT) As Long

Dim lRet As Long
Dim sdi As EMRSTRETCHDIBITS

    If (EnhMetaRec.iType = EMR_STRETCHDIBITS) Then
       'Get the Dimensions of the original Image
       ' Copy rec to our local copy
       apiCopyMemory sdi, EnhMetaRec, Len(sdi)
       If sdi.cxSrc > OptData.right Then
            OptData.right = sdi.cxSrc
            OptData.Bottom = sdi.cySrc
       End If
       lRet = 1
    Else
        lRet = 1
    End If

    EnhMetaFileProcInfo = lRet
End Function

Public Function EnumEMFGetDimension(hEMF As Long, hDC As Long, Width As Long, Height As Long) As Boolean
Dim rcInfo As RECT
Dim rcOutPut As RECT
Dim lRet As Long

' Supply dummy values otherwise the GDI will not enumerate the Metafile records.
rcOutPut.right = 640
rcOutPut.Bottom = 480
    lRet = EnumEnhMetaFile(hDC, hEMF, AddressOf EnhMetaFileProcInfo, rcInfo, rcOutPut)
    ' Retrieve and return the Width and Height vars supplied by the
    ' EnhMetafileProcInfo function.
    Width = rcInfo.right
    Height = rcInfo.Bottom
    EnumEMFGetDimension = lRet
End Function


class: cDIBSection

[Quelltext bearbeiten]


Option Explicit
        '*******************************************
        'DEVELOPED AND TESTED UNDER MICROSOFT WORD 2000 or Higher VBA
        ' Microsoft Word 97 requires two lines of code to be changed
        ' because there is no native support for AddressOf.
        ' There is a separate Word 97 version of this utility!
        '
        'Copyright: Lebans Holdings 1999 Ltd.
        '           Please feel free to use any/all of this code within your
        '           own application, whether Private or Commercial,
        '           without cost or obligation.
        '           Please include the one line Copyright notice
        '           if you use this function in your own code.
        '           This code may not be sold by itself or as part
        '           of a collection.
        '
        'Name:      CDIBSection
        '
        ' Dependencies:
        '           modEnumMetafile
        '           clsCommonDialog
        '
        'Purpose:   Provides a method to save an embedded Image
        '           within a Word document to either a disk based
        '           Bitmap or Enhanced Metafile.
        '
        'Author:    Stephen Lebans
        'Email:     Stephen@lebans.com
        'Web Site:  www.lebans.com
        'Date:      Apr 17, 2004, 11:11:11 PM
        '
        'Called by: Any
        '
        'Inputs:    None. Requires that the Active Control on the
        '           Word Document contain an Image. All Images are
        '           saved at a 24 bit depth for this release.
        '
        'Credits:
        'VBAccelerator.Com for the DIBSection to disk Bitmap file function
        'http://www.vbaccelerator.com/home/VB/Code/vbMedia/DIB_Sections/index.asp
        '
        'BUGS:
        'No serious bugs reported at this point in time.
        'Please report any bugs to my email address.
        '
        'What's Missing:
        ' Ability to automate this process and programmatically
        ' save all Images in the current document
        '
        'HOW TO USE:
        '
        '*******************************************


Private Type RECT
    Left As Long
    top As Long
    right As Long
    Bottom As Long
End Type

Private Type SIZEL
    cx As Long
    cy As Long
End Type

Private Type emr
        iType As Long
        nSize As Long
End Type

Private Type EMRSTRETCHDIBITS
        pEmr As emr
        rclBounds As RECT
        xDest As Long
        yDest As Long
        xSrc As Long
        ySrc As Long
        cxSrc As Long
        cySrc As Long
        offBmiSrc As Long
        cbBmiSrc As Long
        offBitsSrc As Long
        cbBitsSrc As Long
        iUsageSrc As Long
        dwRop As Long
        cxDest As Long
        cyDest As Long
End Type

Private Type ENHMETAHEADER
        iType As Long
        nSize As Long
        rclBounds As RECT
        rclFrame As RECT
        dSignature As Long
        nVersion As Long
        nBytes As Long
        nRecords As Long
        nHandles As Integer
        sReserved As Integer
        nDescription As Long
        offDescription As Long
        nPalEntries As Long
        szlDevice As SIZEL
        szlMillimeters As SIZEL
End Type


Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type


'Bitmap
 Private Const BI_RGB = 0&
  Private Const BI_RLE4 = 2&
  Private Const BI_RLE8 = 1&
  Private Const DIB_RGB_COLORS = 0

Private Type BITMAPINFOHEADER '40 bytes
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long 'ERGBCompression
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type


Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type

Private Const BITMAPTYPE As Integer = &H4D42

Private Type BITMAPFILEHEADER
   bfType As Integer
   bfSize As Long
   bfReserved1 As Integer
   bfReserved2 As Integer
   bfOffBits As Long
End Type

Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

Private Type DIBSECTION
    dsBm As BITMAP
    dsBmih As BITMAPINFOHEADER
    dsBitfields(2) As Long
    dshSection As Long
    dsOffset As Long
End Type


'Open the clipboard
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
' Clear the ClipBoard
Private Declare Function EmptyClipboard Lib "user32" () 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

' Memory Allocation
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
 ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

' Create/Write file
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, lpSecurityAttributes As Any, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long

Private Declare Function WriteFile Lib "kernel32" _
(ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

' File constants
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_FLAG_RANDOM_ACCESS = &H10000000
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const INVALID_HANDLE_VALUE = -1

Private Const CREATE_NEW = 1
Private Const CREATE_ALWAYS = 2
Private Const OPEN_EXISTING = 3
Private Const OPEN_ALWAYS = 4
Private Const TRUNCATE_EXISTING = 5

Private Const FILE_BEGIN = 0
Private Const FILE_CURRENT = 1
Private Const FILE_END = 2

' Metafile Record ID's
Private Const EMR_GDICOMMENT = 70
Private Const EMR_STRETCHDIBITS = 81
Private Const EMR_EOF = 14

Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hDC As Long, pBitmapInfo As BITMAPINFO, _
ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function apiGetDeviceCaps Lib "gdi32" _
Alias "GetDeviceCaps" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

Private Declare Function apiPlayEnhMetaFile Lib "gdi32" Alias "PlayEnhMetaFile" _
(ByVal hDC As Long, ByVal hEMF As Long, lpRect As RECT) As Long

Private Declare Function apiCreateEnhMetaFileRECT Lib "gdi32" _
Alias "CreateEnhMetaFileA" (ByVal hDCref As Long, _
ByVal lpFileName As String, ByRef lpRect As RECT, ByVal lpDescription As String) As Long

Private Declare Function apiDeleteEnhMetaFile Lib "gdi32" Alias "DeleteEnhMetaFile" _
(ByVal hEMF As Long) As Long

Private Declare Function apiCloseEnhMetaFile Lib "gdi32" Alias "CloseEnhMetaFile" _
(ByVal hDC As Long) As Long

Private Declare Function GetEnhMetaFileHeader Lib "gdi32" _
(ByVal hEMF As Long, ByVal cbBuffer As Long, lpemh As Any) As Long ' ENHMETAHEADER) As Long

Private Declare Function apiGetDC Lib "user32" _
  Alias "GetDC" (ByVal hwnd As Long) As Long

Private Declare Function apiReleaseDC Lib "user32" _
  Alias "ReleaseDC" (ByVal hwnd As Long, _
  ByVal hDC As Long) As Long
Private Declare Function apiDeleteDC Lib "gdi32" _
  Alias "DeleteDC" (ByVal hDC As Long) As Long
  
Private Declare Function apiCreateSolidBrush Lib "gdi32" Alias "CreateSolidBrush" _
    (ByVal crColor As Long) As Long

Private Declare Function apiFillRect Lib "user32" Alias "FillRect" _
(ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long


' Predefined Clipboard Formats
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_DIB = 8
Private Const CF_ENHMETAFILE = 14

'  Device Parameters for GetDeviceCaps()
' GetDeviceCaps
Private Const HORZSIZE = 4           '  Horizontal size in millimeters
Private Const VERTSIZE = 6           '  Vertical size in millimeters
Private Const HORZRES = 8            '  Horizontal width in pixels
Private Const VERTRES = 10           '  Vertical width in pixels
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88

' How many Twips in 1 inch
Private Const TWIPSPERINCH = 1440

' Handle to the current DIBSection:
Private m_hDib As Long
' Handle to the old bitmap in the DC, for clear up:
Private m_hBmpOld As Long
' Handle to the Device context holding the DIBSection:
Private m_hDC As Long
' Address of memory pointing to the DIBSection's bits:
Private m_lPtr As Long
' Type containing the Bitmap information:
Private m_bmi As BITMAPINFO
' Handle to the Memory Enhanced Metafile we get from the Clipboard
Private m_hEMF As Long

' Temp var
Dim lngRet As Long



Public Function CreateDIB( _
  ByVal lhdc As Long, _
  ByVal lWidth As Long, _
  ByVal lHeight As Long, _
  ByRef hDib As Long, _
  Optional ByVal PelsX As Long = 0, Optional ByVal PelsY As Long = 0 _
  ) As Boolean
   
  With m_bmi.bmiHeader
    .biSize = Len(m_bmi.bmiHeader)
    .biWidth = lWidth
    .biHeight = lHeight
    .biPlanes = 1
    ' Always use 24bits for this clas
    .biBitCount = 24
    .biCompression = BI_RGB
    .biSizeImage = BytesPerScanLine * .biHeight
    .biXPelsPerMeter = PelsX
    .biYPelsPerMeter = PelsY
  End With
  
  '' Create our DibSection. Pointer to bitmap data is in m_lPtr
  hDib = CreateDIBSection(lhdc, m_bmi, DIB_RGB_COLORS, m_lPtr, 0, 0)
  
  CreateDIB = (hDib <> 0)

End Function


Public Function Create(ByVal lWidth As Long, ByVal lHeight As Long, _
Optional ByVal PelsX As Long = 0, Optional ByVal PelsY As Long = 0) As Boolean
  
  ' Always cleanup before we start!
  CleanUp
  
  m_hDC = CreateCompatibleDC(0)
  
  If (m_hDC <> 0) Then
    If (CreateDIB(m_hDC, lWidth, lHeight, m_hDib, PelsX, PelsY)) Then
      m_hBmpOld = SelectObject(m_hDC, m_hDib)
      Create = True
    Else
      Call DeleteObject(m_hDC)
      m_hDC = 0
    End If
  End If

End Function


Public Function EMFToDIB() As Boolean
' Play the Metafile into the DIBSection

Dim blRet As Boolean
Dim hDCtemp As Long

' Instance of EMF Header structure
Dim mh As ENHMETAHEADER
 
' Current Screen Resolution
Dim lngXdpi As Long

' Used to convert Metafile dimensions to pixels
Dim sngConvertX As Single
Dim sngConvertY As Single

' Pels per meter for Bitmapinfo
' Some apps will read thsi value to determine DPI for
' display purposes
Dim PelsX As Long, PelsY As Long

' Image dimensions
Dim Width As Long, Height As Long
Dim hDCref As Long
Dim rc As RECT

' Create a temp Device Context
hDCtemp = CreateCompatibleDC(0)

' Get Enhanced Metafile Header
lngRet = GetEnhMetaFileHeader(m_hEMF, Len(mh), mh)

With mh.rclFrame
    ' The rclFrame member Specifies the dimensions,
    ' in .01 millimeter units, of a rectangle that surrounds
    ' the picture stored in the metafile.
    ' I'll show this as seperate steps to aid in understanding
    ' the conversion process.
    
    ' Convert to MM
    sngConvertX = (.right - .Left) * 0.01
    sngConvertY = (.Bottom - .top) * 0.01
     End With
     
    ' Convert to CM
    sngConvertX = sngConvertX * 0.1
    sngConvertY = sngConvertY * 0.1
    ' Convert to Inches
    sngConvertX = sngConvertX / 2.54
    sngConvertY = sngConvertY / 2.54

' DC for the enumeration of the EMF records
'It must be GetDC not CreateCompatibleDC!!!
hDCref = apiGetDC(0)
' See if we can get the original Image dimensions
' From an EMRSTRETCHDIBITS metafile record which
' will exist for any Images that were
' originally Bitmap based.(BMP, Jpeg, Tiff etc.)
blRet = EnumEMFGetDimension(m_hEMF, hDCref, Width, Height)
' Always release the DC as soon as possible
lngRet = apiReleaseDC(0, hDCref)

' Again if Width = 0 then we are dealing with a plain Metafile
' not a DIB wrapped within a Metafile.
' Get the Dimensions from the Metafile Header.
If Width = 0 Then
' Get the Image dimensions directly from the EMH Header
Width = mh.rclBounds.right
Height = mh.rclBounds.Bottom
End If

' Next we need to check and see which dimension values are
' larger, the EnumEMFGetDimension values or the EMF Header values.
' Use Whichever values are larger. This logic will cover the
' case where we have an origina EMF Image but it happens to
' contain one or more calls to the EMRSTRETCHDIBITS record.

If mh.rclBounds.right > Width Then
    Width = mh.rclBounds.right
    Height = mh.rclBounds.Bottom
End If

' The vars sngConvertX and  sngConvertY contain the
' dimensions of the Image in inches.
' We need to convert this to Pixels Per METER.
' First convert to Inches
PelsX = Width / sngConvertX
PelsY = Height / sngConvertY

' A problem here is that we are too accurate compared to
' the rounding used by Word and Explorer. For instance we might
' arrive at a value of 302 DPI when Word originally loaded the
' Image it was only 300 DPI.
' Let's round to the nearest 100th value.
' If the value is under 120 then leave it alone
If PelsX > 120 Then
PelsX = PelsX + 5
PelsY = PelsY + 5
PelsX = PelsX \ 10
PelsY = PelsY \ 10
PelsX = PelsX * 10
PelsY = PelsY * 10
End If
' Now convert Inches to Meters
PelsX = PelsX * 39.37
PelsY = PelsY * 39.37

' Now create our DIBSECTION
Create Width, Height, PelsX, PelsY

'"PLAY" the Enhanced Metafile
' back into the Device Context containing the DIBSection
rc.top = 0
rc.Left = 0
rc.Bottom = m_bmi.bmiHeader.biHeight
rc.right = m_bmi.bmiHeader.biWidth
lngRet = apiPlayEnhMetaFile(m_hDC, m_hEMF, rc)

 
' Success
EMFToDIB = True
End Function


Public Function SaveEMF(strFname As String)
Dim lngRet As Long
Dim blRet As Long

Dim lLength As Long
Dim Width As Long
Dim Height As Long
Dim hDCEMF As Long
Dim hDCref As Long
Dim rc As RECT
' local storage for out copy of the EMF Header
Dim mh As ENHMETAHEADER

' Vars to calculate resolution
Dim sngConvertX As Single
Dim sngConvertY As Single
Dim ImageWidth As Single
Dim ImageHeight As Single
Dim Xdpi As Single
Dim Ydpi As Single
Dim TwipsPerPixelX As Single
Dim TwipsPerPixelY As Single
Dim sngHORZRES As Single
Dim sngVERTRES As Single
Dim sngHORZSIZE As Single
Dim sngVERTSIZE As Single

' To create our EMF
'It must be GetDC not CreateCompatibleDC!!!
hDCref = apiGetDC(0)

' See if we can get the original Image dimensions
' From an EMRSTRETCHDIBITS metafile record which
' will exist for any Images that were
' originally Bitmap based.(BMP, Jpeg, Tiff etc.)
blRet = EnumEMFGetDimension(m_hEMF, hDCref, Width, Height)
' Again if Width = 0 then we are dealing with a plain Metafile
' not a DIB wrapped within a Metafile.
' Get the Dimensions from the Metafile Header.
If Width = 0 Then
    ' Get Enhanced Metafile Header
    lngRet = GetEnhMetaFileHeader(m_hEMF, Len(mh), mh)
    ' It is a plain Metafile we are dealing with
    ' not a DIB wrapped in a Metafile.
    ' Get the Dimensions from the Metafile Header
    Width = mh.rclBounds.right
    Height = mh.rclBounds.Bottom
End If

' Next we need to check and see which dimension values are
' larger, the EnumEMFGetDimension values or the EMF Header values.
' Use Whichever values are larger. This logic will cover the
' case where we have an origina EMF Image but it happens to
' contain one or more calls to the EMRSTRETCHDIBITS record.

If mh.rclBounds.right > Width Then
    Width = mh.rclBounds.right
    Height = mh.rclBounds.Bottom
End If


' Setup
' April 19-2004rc.right = Width
'rc.Bottom = Height
ImageWidth = Width
ImageHeight = Height


' Calculate the current Screen resolution.
' I used to simply use GetDeviceCaps and
' LOGPIXELSY/LOGPIXELSX. Unfortunately this does not yield accurate results
' with Metafiles.  LOGPIXELSY will return the value of 96dpi or 120dpi
' depending on the current Windows setting for Small Fonts or Large Fonts.
' Thanks to Feng Yuan's book "Windows Graphics Programming" for
' explaining the correct method to ascertain screen resolution.

' Let's grab the current size and resolution of our Screen DC.
sngHORZRES = apiGetDeviceCaps(hDCref, HORZRES)
sngVERTRES = apiGetDeviceCaps(hDCref, VERTRES)
sngHORZSIZE = apiGetDeviceCaps(hDCref, HORZSIZE)
sngVERTSIZE = apiGetDeviceCaps(hDCref, VERTSIZE)

' Convert millimeters to inches
sngConvertX = (sngHORZSIZE * 0.1) / 2.54
sngConvertY = (sngVERTSIZE * 0.1) / 2.54

' Convert to DPI
sngConvertX = sngHORZRES / sngConvertX
sngConvertY = sngVERTRES / sngConvertY
Xdpi = sngConvertX
Ydpi = sngConvertY

' Calculate TwipsPerPixel
TwipsPerPixelX = TWIPSPERINCH / Xdpi
TwipsPerPixelY = TWIPSPERINCH / Ydpi

' Convert pixels to TWIPS
ImageWidth = ImageWidth * TwipsPerPixelX
ImageHeight = ImageHeight * TwipsPerPixelY

' Convert TWIPS to Inches
ImageWidth = ImageWidth / 1440
ImageHeight = ImageHeight / 1440

' Convert Inches to .01 mm
ImageWidth = (ImageWidth * 2.54) * 1000
ImageHeight = (ImageHeight * 2.54) * 1000

' Ready to call the Create Metafile API
rc.Bottom = ImageHeight
rc.right = ImageWidth
rc.Left = 0
rc.top = 0
' Create the Metafile
hDCEMF = apiCreateEnhMetaFileRECT(hDCref, strFname, rc, vbNullString)

If hDCEMF = 0 Then
    MsgBox "Could not create Metafile", vbCritical
    lngRet = apiReleaseDC(0, hDCref)
    Exit Function
End If

' Now play the Memory Metafile into our Disk based Metafile
rc.Bottom = Height
rc.right = Width
lngRet = apiPlayEnhMetaFile(hDCEMF, m_hEMF, rc)

' Now close the file based EMF
lngRet = apiCloseEnhMetaFile(hDCEMF)
' Delete it(not really...it merely releases the ref to it completely.
lngRet = apiDeleteEnhMetaFile(lngRet)
' Always release what you get
lngRet = apiReleaseDC(0, hDCref)


End Function

Public Sub FreeMetafile()
If m_hEMF <> 0 Then
    ' Finally delete the memory Metafile
    lngRet = apiDeleteEnhMetaFile(m_hEMF)
    m_hEMF = 0
End If
End Sub

Public Property Get BytesPerScanLine() As Long
  ' Scans must align on dword boundaries:
  BytesPerScanLine = (m_bmi.bmiHeader.biWidth * (m_bmi.bmiHeader.biBitCount / 8) + 3) And &HFFFFFFFC
End Property

Public Property Get dib_width() As Long
  dib_width = m_bmi.bmiHeader.biWidth
End Property

Public Property Get dib_height() As Long
  dib_height = m_bmi.bmiHeader.biHeight
End Property

Public Property Get dib_channels() As Long
  dib_channels = m_bmi.bmiHeader.biBitCount / 8
End Property

Public Property Get hDC() As Long
  hDC = m_hDC
End Property

Public Property Get hDib() As Long
  hDib = m_hDib
End Property

Public Property Get DIBSectionBitsPtr() As Long
  DIBSectionBitsPtr = m_lPtr
End Property

Public Sub CleanUp()
  
  If (m_hDC <> 0) Then
    If (m_hDib <> 0) Then
      Call SelectObject(m_hDC, m_hBmpOld)
      Call DeleteObject(m_hDib)
    End If
    Call DeleteObject(m_hDC)
  End If
  
  m_hDC = 0
  m_hDib = 0
  m_hBmpOld = 0
  m_lPtr = 0

  m_bmi.bmiColors.rgbBlue = 0
  m_bmi.bmiColors.rgbGreen = 0
  m_bmi.bmiColors.rgbRed = 0
  m_bmi.bmiColors.rgbReserved = 0
  m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
  m_bmi.bmiHeader.biWidth = 0
  m_bmi.bmiHeader.biHeight = 0
  m_bmi.bmiHeader.biPlanes = 0
  m_bmi.bmiHeader.biBitCount = 0
  m_bmi.bmiHeader.biClrUsed = 0
  m_bmi.bmiHeader.biClrImportant = 0
  m_bmi.bmiHeader.biCompression = 0

End Sub

Private Sub Class_Terminate()
  CleanUp
  FreeMetafile
End Sub


'Public Function SavePicture(ByVal sFileName As String) As Boolean
'Dim lC As Long, i As Long
'   ' Save DIBSection to disk based Bitmap file
'   SavePicture = SaveToBitmap(m_lPtr, sFileName)
'End Function

Public Function SavePicture(ByVal sFileName As String) As Boolean
'ToBitmap(ByVal m_lPtr As Long, ByVal sFileName As String) As Boolean

    Dim tBH As BITMAPFILEHEADER
    Dim tRGBQ As RGBQUAD
    Dim hFile As Long
    Dim lBytesWritten As Long
    Dim lSize As Long
    Dim lR As Long
    Dim bErr As Boolean
    Dim hMem As Long, lPtr As Long
    Dim lErr As Long
    Dim lTemp As Long
    Dim iTemp As Integer
    
    ' Do we have a valid pointer to our DIBSection BITS?
    If m_lPtr = 0 Then
        SavePicture = False
        Exit Function
    End If
       
    ' Init the BITMAPFILEHEADER
    With tBH
       .bfType = BITMAPTYPE
    
       .bfOffBits = 14 + Len(m_bmi)
       .bfSize = .bfOffBits + m_bmi.bmiHeader.biSizeImage
    End With
    hFile = CreateFile(sFileName, _
                  GENERIC_READ Or GENERIC_WRITE, _
                   ByVal 0&, _
                   ByVal 0&, _
                   CREATE_ALWAYS, _
                   FILE_ATTRIBUTE_NORMAL, _
                   0)
    If hFile = 0 Then
        SavePicture = False
        Exit Function
    End If
          
    ' Writing the BITMAPFILEINFOHEADER is somewhat painful
    ' due to non-byte alignment of structure...
    hMem = GlobalAlloc(GPTR, 14)
    lPtr = GlobalLock(hMem)
    iTemp = tBH.bfType
    apiCopyMemory ByVal lPtr, tBH.bfType, 2
    lTemp = tBH.bfSize
    apiCopyMemory ByVal lPtr + 2, tBH.bfSize, 4
    apiCopyMemory ByVal lPtr + 6, 0&, 4
    lTemp = tBH.bfOffBits
    apiCopyMemory ByVal lPtr + 10, tBH.bfOffBits, 4
    lSize = 14
    lR = WriteFile(hFile, ByVal lPtr, lSize, lBytesWritten, ByVal 0&)
    GlobalUnlock hMem
    GlobalFree hMem
    
    ' Write the BITMAPINFOHEADER
    lSize = Len(m_bmi)
    lR = WriteFile(hFile, m_bmi, lSize, lBytesWritten, ByVal 0&)
    
    ' Write the bitmap data
    lSize = m_bmi.bmiHeader.biSizeImage
    lR = WriteFile(hFile, ByVal m_lPtr, lSize, lBytesWritten, ByVal 0&)
     
    
    ' Cleanup
    CloseHandle hFile
    SavePicture = True

End Function


Public Function GetClipBoardOLE(Optional ClearClipBoard As Boolean = True) As Boolean
' Get the Clipboard contents after we have
' copied the contents of the control.

' Error handling in calling function

On Error GoTo error_clip

' Handles for graphic Objects
Dim hClipBoard As Long
Dim hEMF As Long

' Delete any existing Metafile handle
Call FreeMetafile

' Open the ClipBoard
hClipBoard = OpenClipboard(0&)
If hClipBoard = 0 Then
    Err.Raise vbObjectError + 514
End If
 
' Get a handle to the Bitmap
hEMF = GetClipboardData(CF_ENHMETAFILE)
If hEMF = 0 Then
    Err.Raise vbObjectError + 515
End If
' Make a local copy in memory
m_hEMF = CopyEnhMetaFile(hEMF, vbNullString)
If m_hEMF = 0 Then
    Err.Raise vbObjectError + 516
End If


' Return our copy of the memory metafile
GetClipBoardOLE = True

' Exit normally
exit_clip:
' Clear the ClipBoard?
If ClearClipBoard = True Then
    Call EmptyClipboard
End If
If hClipBoard <> 0 Then
    hClipBoard = CloseClipboard
End If
Exit Function

error_clip:
 ' Return False
GetClipBoardOLE = False
Resume exit_clip
End Function


Public Function fSaveDialog(sTitle As String, sFilter As String) As String
' Calls the API File Dialog Window
' Returns full path to the existing File

On Error GoTo Err_fFileDialog

' Call the File Common Dialog Window
Dim clsDialog As Object

Set clsDialog = New clsCommonDialog

If sFilter = "EMF" Then
    clsDialog.Filter = "EMF (*.EMF)" & Chr$(0) & "*.EMF" & Chr$(0)
ElseIf sFilter = "BMP" Then
    clsDialog.Filter = "BMP (*.BMP)" & Chr$(0) & "*.BMP" & Chr$(0)
Else
    clsDialog.Filter = "ALL (*.*)" & Chr$(0) & "*.*" & Chr$(0)
End If

' Fill in our properties
clsDialog.hDC = 0
clsDialog.MaxFileSize = 256
clsDialog.Max = 256
clsDialog.FileTitle = vbNullString
clsDialog.DialogTitle = sTitle
clsDialog.InitDir = vbNullString
clsDialog.DefaultExt = vbNullString

' Display the File Dialog
clsDialog.ShowSave

' See if user clicked Cancel or entered a string
fSaveDialog = clsDialog.FileName
If Len(fSaveDialog & vbNullString) = 0 Then
    ' Raise the exception
    Err.Raise vbObjectError + 514, "cDIBSection.fFileDialog", _
    "Please enter a valid filename"
End If


Exit_fFileDialog:

Err.Clear
Set clsDialog = Nothing
Exit Function

Err_fFileDialog:
fSaveDialog = ""
MsgBox Err.Description, vbOKOnly, Err.Source & ":1"  '& Err.Number
Resume Exit_fFileDialog

End Function

class: clsCommonDialog

[Quelltext bearbeiten]



'­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­ 
' VERSION 1.0 CLASS
' BEGIN
'   MultiUse = -1  'True
'   Persistable = 0  'NotPersistable
'   DataBindingBehavior = 0  'vbNone
'   DataSourceBehavior = 0   'vbNone
'   MTSTransactionMode = 0   'NotAnMTSObject
' End
' Attribute VB_Name = "clsCommonDialog"
' Attribute VB_GlobalNameSpace = False
' Attribute VB_Creatable = True
' Attribute VB_PredeclaredId = False
' Attribute VB_Exposed = True
'­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­ 

Option Explicit
' This code is from the Microsoft Knowledge Base.


'API function called by ChooseColor method
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long

'API function called by ShowOpen method
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFilename) As Long

'API function called by ShowSave method
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OpenFilename) As Long

'API function to retrieve extended error information
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

'API memory functions
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
         hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
 

'constants for API memory functions
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
 
 
'data buffer for the ChooseColor function
Private Type ChooseColor
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        rgblRetult As Long
        lpCustColors As Long
        flags As Long
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type

'data buffer for the GetOpenFileName and GetSaveFileName functions
Private Type OpenFilename
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        iFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type


'internal property buffers

Private iAction As Integer         'internal buffer for Action property
Private bCancelError As Boolean    'internal buffer for CancelError property
Private lColor As Long             'internal buffer for Color property
Private lCopies As Long            'internal buffer for lCopies property
Private sDefaultExt As String      'internal buffer for sDefaultExt property
Private sDialogTitle As String     'internal buffer for DialogTitle property
Private sFileName As String        'internal buffer for FileName property
Private sFileTitle As String       'internal buffer for FileTitle property
Private sFilter As String          'internal buffer for Filter property
Private iFilterIndex As Integer    'internal buffer for FilterIndex property
Private lFlags As Long             'internal buffer for Flags property
Private lhdc As Long               'internal buffer for hdc property
Private sInitDir As String         'internal buffer for InitDir property
Private lMax As Long               'internal buffer for Max property
Private lMaxFileSize As Long       'internal buffer for MaxFileSize property
Private lMin As Long               'internal buffer for Min property
Private objObject As Object        'internal buffer for Object property

Private lApiReturn As Long          'internal buffer for APIReturn property
Private lExtendedError As Long      'internal buffer for ExtendedError property



'constants for color dialog

Private Const CDERR_DIALOGFAILURE = &HFFFF
Private Const CDERR_FINDRESFAILURE = &H6
Private Const CDERR_GENERALCODES = &H0
Private Const CDERR_INITIALIZATION = &H2
Private Const CDERR_LOADRESFAILURE = &H7
Private Const CDERR_LOADSTRFAILURE = &H5
Private Const CDERR_LOCKRESFAILURE = &H8
Private Const CDERR_MEMALLOCFAILURE = &H9
Private Const CDERR_MEMLOCKFAILURE = &HA
Private Const CDERR_NOHINSTANCE = &H4
Private Const CDERR_NOHOOK = &HB
Private Const CDERR_NOTEMPLATE = &H3
Private Const CDERR_REGISTERMSGFAIL = &HC
Private Const CDERR_STRUCTSIZE = &H1


'constants for file dialog

Private Const FNERR_BUFFERTOOSMALL = &H3003
Private Const FNERR_FILENAMECODES = &H3000
Private Const FNERR_INVALIDFILENAME = &H3002
Private Const FNERR_SUBCLASSFAILURE = &H3001

Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
            
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
            
Private Const BIF_RETURNONLYFSDIRS = &H1

Public Property Get Filter() As String
    'return object's Filter property
    Filter = sFilter
End Property

Public Sub ShowColor()
    'display the color dialog box
    
    Dim tChooseColor As ChooseColor
    Dim alCustomColors(15) As Long
    Dim lCustomColorSize As Long
    Dim lCustomColorAddress As Long
    Dim lMemHandle As Long
    
    Dim n As Integer
        
    On Error GoTo ShowColorError
    
    
    '***    init property buffers
    
    iAction = 3  'Action property - ShowColor
    lApiReturn = 0  'APIReturn property
    lExtendedError = 0  'ExtendedError property
    
    
    '***    prepare tChooseColor data
    
    'lStructSize As Long
    tChooseColor.lStructSize = Len(tChooseColor)
    
    'hwndOwner As Long
    tChooseColor.hwndOwner = 0& 'lhdc

    'hInstance As Long
    
    'rgblRetult As Long
    tChooseColor.rgblRetult = lColor
    
    'lpCustColors As Long
    ' Fill custom colors array with all white
    For n = 0 To UBound(alCustomColors)
        alCustomColors(n) = &HFFFFFF
    Next
    ' Get size of memory needed for custom colors
    lCustomColorSize = Len(alCustomColors(0)) * 16
    ' Get a global memory block to hold a copy of the custom colors
    lMemHandle = GlobalAlloc(GHND, lCustomColorSize)
    
    If lMemHandle = 0 Then
        Exit Sub
    End If
    ' Lock the custom color's global memory block
    lCustomColorAddress = GlobalLock(lMemHandle)
    If lCustomColorAddress = 0 Then
        Exit Sub
    End If
    ' Copy custom colors to the global memory block
    Call CopyMemory(ByVal lCustomColorAddress, alCustomColors(0), lCustomColorSize)
 
    tChooseColor.lpCustColors = lCustomColorAddress
    
    'flags As Long
    tChooseColor.flags = lFlags
        
    'lCustData As Long
    'lpfnHook As Long
    'lpTemplateName As String
    
    
    '***    call the ChooseColor API function
    lApiReturn = ChooseColor(tChooseColor)
    
    
    '***    handle return from ChooseColor API function
    Select Case lApiReturn
        
        Case 0  'user canceled
        If bCancelError = True Then
            'generate an error
            On Error GoTo 0
            Err.Raise Number:=vbObjectError + 894, _
                Description:="Cancel Pressed"
            Exit Sub
        End If
        
        Case 1  'user selected a color
            'update property buffer
            lColor = tChooseColor.rgblRetult
        
        Case Else   'an error occured
            'call CommDlgExtendedError
            lExtendedError = CommDlgExtendedError
        
    End Select

Exit Sub

ShowColorError:
    Exit Sub
End Sub

Public Sub ShowOpen()
    'display the file open dialog box
    ShowFileDialog (1)  'Action property - ShowOpen
End Sub

Public Sub ShowSave()
    'display the file save dialog box
    ShowFileDialog (2)  'Action property - ShowSave
End Sub

Public Property Get FileName() As String
    'return object's FileName property
    FileName = sFileName
End Property

Public Property Let FileName(vNewValue As String)
    'assign object's FileName property
    sFileName = vNewValue
End Property

Public Property Let Filter(vNewValue As String)
    'assign object's Filter property
    sFilter = vNewValue
End Property

Private Function sLeftOfNull(ByVal sIn As String)
    'returns the part of sIn preceding Chr$(0)
    Dim lNullPos As Long
    
    'init output
    sLeftOfNull = sIn
    
    'get position of first Chr$(0) in sIn
    lNullPos = InStr(sIn, Chr$(0))
    
    'return part of sIn to left of first Chr$(0) if found
    If lNullPos > 0 Then
        sLeftOfNull = Mid$(sIn, 1, lNullPos - 1)
    End If
    
End Function


Public Property Get Action() As Integer
    'Return object's Action property
    Action = iAction
End Property

Private Function sAPIFilter(sIn)
    'prepares sIn for use as a filter string in API common dialog functions
    Dim lChrNdx As Long
    Dim sOneChr As String
    Dim sOutStr As String
    
    'convert any | characters to nulls
    For lChrNdx = 1 To Len(sIn)
        sOneChr = Mid$(sIn, lChrNdx, 1)
        If sOneChr = "|" Then
            sOutStr = sOutStr & Chr$(0)
        Else
            sOutStr = sOutStr & sOneChr
        End If
    Next
    
    'add a null to the end
    sOutStr = sOutStr & Chr$(0)
    
    'return sOutStr
    sAPIFilter = sOutStr
    
End Function

Public Property Get FilterIndex() As Integer
    'return object's FilterIndex property
    FilterIndex = iFilterIndex
End Property

Public Property Let FilterIndex(vNewValue As Integer)
    iFilterIndex = vNewValue
End Property

Public Property Get CancelError() As Boolean
    'Return object's CancelError property
    CancelError = bCancelError
End Property

Public Property Let CancelError(vNewValue As Boolean)
    'Assign object's CancelError property
    bCancelError = vNewValue
End Property

Public Property Get Color() As Long
    'return object's Color property
    Color = lColor
End Property

Public Property Let Color(vNewValue As Long)
    'assign object's Color property
    lColor = vNewValue
End Property

Public Property Get DefaultExt() As String
    'return object's DefaultExt property
    DefaultExt = sDefaultExt
End Property

Public Property Let DefaultExt(vNewValue As String)
    'assign object's DefaultExt property
    sDefaultExt = vNewValue
End Property

Public Property Get DialogTitle() As String
    'return object's FileName property
    DialogTitle = sDialogTitle
End Property

Public Property Let DialogTitle(vNewValue As String)
    'assign object's DialogTitle property
    sDialogTitle = vNewValue
End Property

Public Property Get flags() As Long
    'return object's Flags property
    flags = lFlags
End Property

Public Property Let flags(vNewValue As Long)
    'assign object's Flags property
    lFlags = vNewValue
End Property

Public Property Get hDC() As Long
    'Return object's hDC property
    hDC = lhdc
End Property

Public Property Let hDC(vNewValue As Long)
    'Assign object's hDC property
    lhdc = vNewValue
End Property

Public Property Get InitDir() As String
    'Return object's InitDir property
    InitDir = sInitDir
End Property

Public Property Let InitDir(vNewValue As String)
    'Assign object's InitDir property
    sInitDir = vNewValue
End Property

Public Property Get Max() As Long
    'Return object's Max property
    Max = lMax
End Property

Public Property Let Max(vNewValue As Long)
    'Assign object's - property
    lMax = vNewValue
End Property

Public Property Get MaxFileSize() As Long
    'Return object's MaxFileSize property
    MaxFileSize = lMaxFileSize
End Property

Public Property Let MaxFileSize(vNewValue As Long)
    'Assign object's MaxFileSize property
    lMaxFileSize = vNewValue
End Property

Public Property Get Min() As Long
    'Return object's Min property
    Min = lMin
End Property

Public Property Let Min(vNewValue As Long)
    'Assign object's Min property
    lMin = vNewValue
End Property

Public Property Get Object() As Object
    'Return object's Object property
    Object = objObject
End Property

Public Property Let Object(vNewValue As Object)
    'Assign object's Object property
    objObject = vNewValue
End Property

Public Property Get FileTitle() As String
    'return object's FileTitle property
    FileTitle = sFileTitle
End Property

Public Property Let FileTitle(vNewValue As String)
    'assign object's FileTitle property
    sFileTitle = vNewValue
End Property

Public Property Get APIReturn() As Long
    'return object's APIReturn property
    APIReturn = lApiReturn
End Property

Public Property Get ExtendedError() As Long
    'return object's ExtendedError property
    ExtendedError = lExtendedError
End Property


Private Function sByteArrayToString(abBytes() As Byte) As String
    'return a string from a byte array
    Dim lBytePoint As Long
    Dim lByteVal As Long
    Dim sOut As String
    
    'init array pointer
    lBytePoint = LBound(abBytes)
    
    'fill sOut with characters in array
    While lBytePoint <= UBound(abBytes)
        
        lByteVal = abBytes(lBytePoint)
        
        'return sOut and stop if Chr$(0) is encountered
        If lByteVal = 0 Then
            sByteArrayToString = sOut
            Exit Function
        Else
            sOut = sOut & Chr$(lByteVal)
        End If
        
        lBytePoint = lBytePoint + 1
    
    Wend
    
    'return sOut if Chr$(0) wasn't encountered
    sByteArrayToString = sOut
    
End Function
Private Sub ShowFileDialog(ByVal iAction As Integer)
    
    'display the file dialog for ShowOpen or ShowSave
    
    Dim tOpenFile As OpenFilename
    Dim lMaxSize As Long
    Dim sFileNameBuff As String
    Dim sFileTitleBuff As String
    
    On Error GoTo ShowFileDialogError
    
    
    '***    init property buffers
    
    iAction = iAction  'Action property
    lApiReturn = 0  'APIReturn property
    lExtendedError = 0  'ExtendedError property
        
    
    '***    prepare tOpenFile data
    
    'tOpenFile.lStructSize As Long
    tOpenFile.lStructSize = Len(tOpenFile)
    
    'tOpenFile.hWndOwner As Long - init from hdc property
    tOpenFile.hwndOwner = 0 'Application.hWndAccessApp ' 0& ' Just use 0 !
    
    'tOpenFile.lpstrFilter As String - init from Filter property
    tOpenFile.lpstrFilter = sAPIFilter(sFilter)
        
    'tOpenFile.iFilterIndex As Long - init from FilterIndex property
    tOpenFile.iFilterIndex = iFilterIndex
    
    'tOpenFile.lpstrFile As String
        'determine size of buffer from MaxFileSize property
        If lMaxFileSize > 0 Then
            lMaxSize = lMaxFileSize
        Else
            lMaxSize = 256
        End If
    
    'tOpenFile.lpstrFile As Long - init from FileName property
        'prepare sFileNameBuff
        sFileNameBuff = sFileName
        'pad with spaces
        While Len(sFileNameBuff) < lMaxSize - 1
            sFileNameBuff = sFileNameBuff & " "
        Wend
        'trim to length of lMaxFileSize - 1
       sFileNameBuff = Mid$(sFileNameBuff, 1, lMaxFileSize - 1)
        'null terminate
        sFileNameBuff = sFileNameBuff & Chr$(0)
    tOpenFile.lpstrFile = sFileNameBuff
    
    'nMaxFile As Long - init from MaxFileSize property
    If lMaxFileSize <> 255 Then  'default is 255
        tOpenFile.nMaxFile = lMaxFileSize
    End If
            
    'lpstrFileTitle As String - init from FileTitle property
        'prepare sFileTitleBuff
        sFileTitleBuff = sFileTitle
        'pad with spaces
        While Len(sFileTitleBuff) < lMaxSize - 1
            sFileTitleBuff = sFileTitleBuff & " "
        Wend
        'trim to length of lMaxFileSize - 1
        sFileTitleBuff = Mid$(sFileTitleBuff, 1, lMaxFileSize - 1)
        'null terminate
        sFileTitleBuff = sFileTitleBuff & Chr$(0)
    tOpenFile.lpstrFileTitle = sFileTitleBuff
        
    'tOpenFile.lpstrInitialDir As String - init from InitDir property
    tOpenFile.lpstrInitialDir = sInitDir
    
    'tOpenFile.lpstrTitle As String - init from DialogTitle property
    tOpenFile.lpstrTitle = sDialogTitle
    
    'tOpenFile.flags As Long - init from Flags property
    tOpenFile.flags = lFlags
        
    'tOpenFile.lpstrDefExt As String - init from DefaultExt property
    tOpenFile.lpstrDefExt = sDefaultExt
    
    
    '***    call the GetOpenFileName API function
    Select Case iAction
        Case 1  'ShowOpen
            lApiReturn = GetOpenFileName(tOpenFile)
        Case 2  'ShowSave
            lApiReturn = GetSaveFileName(tOpenFile)
        Case Else   'unknown action
            Exit Sub
    End Select
    
    
    '***    handle return from GetOpenFileName API function
    Select Case lApiReturn
        
        Case 0  'user canceled
        If bCancelError = True Then
            'generate an error
            Err.Raise (2001)
            Exit Sub
        End If
        
        Case 1  'user selected or entered a file
            'sFileName gets part of tOpenFile.lpstrFile to the left of first Chr$(0)
            sFileName = sLeftOfNull(tOpenFile.lpstrFile)
            sFileTitle = sLeftOfNull(tOpenFile.lpstrFileTitle)
        
        Case Else   'an error occured
            'call CommDlgExtendedError
            lExtendedError = CommDlgExtendedError
        
    End Select
    

Exit Sub

ShowFileDialogError:
    
    Exit Sub

End Sub




Private Sub Class_Initialize()
Me.hDC = 0
Me.MaxFileSize = 256
Me.Max = 256
Me.FileTitle = vbNullString
Me.DialogTitle = "Please Select a File"
Me.InitDir = vbNullString
Me.DefaultExt = vbNullString
End Sub




'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Terry Kreft



Public Function BrowseFolder(szDialogTitle As String) As String
  Dim x As Long, bi As BROWSEINFO, dwIList As Long
  Dim szPath As String, wPos As Integer
  
    With bi
        .hOwner = 0 'hWndAccessApp
        .lpszTitle = szDialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    
    If x Then
        wPos = InStr(szPath, Chr(0))
        BrowseFolder = Left$(szPath, wPos - 1)
    Else
        BrowseFolder = ""
    End If
End Function

'*********** Code End *****************