Wikipedia:Archiv/Textverarbeitung/Word2Wiki
Zur Navigation springen
Zur Suche springen
Info[Quelltext bearbeiten]
The contents of this page have moved to: Word2MediaWikiPlus
Code[Quelltext bearbeiten]
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.
- Download the files. (This download is not outdated, it contains a newer version.)
- Go into the Visual Basic Editor
- Create a module: Word2Wiki
- Copy the code into the module
- For the image converter
- Create a module: modEnumMetafile
- Create a class: cDIBSection
- 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 *****************