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 *****************