Attribute VB_Name = "modScreen" Option Explicit '============================================================================================================= ' ' modScreen Module ' ---------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Last Update : December 13, 2000 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : cScreen.cls (Main module) ' ' Description : This module is meant to give you ALL the functionality of the "Screen" VB object plus a whole ' lot more! Some times you do not have access to the Screen object (like within Office VBA ' environments, etc.) and this module can be used instead. This module gives you all the same ' information but uses to the Win32 API to get it... plus properties like TwipsPerPixel are ' reported more accuratly by this class module when compared to the Screen object. ' ' You can also use this class module to draw directly to the display screen similar to DirectDraw... ' and can even resize the screen. ' ' Example Use : ' ------------------------------------------------------------------------------- ' ' Private Scr As cScreen ' ' Private Sub Form_Click() ' Scr.Refresh ' End Sub ' ' Private Sub Form_DblClick() ' Scr.Clear False ' End Sub ' ' Private Sub Form_Load() ' ' Dim MyCounter As Long ' Dim PointArrayX() As Long ' Dim PointArrayY() As Long ' Dim TheX As Long ' Dim TheY As Long ' Dim MyFont As StdFont ' ' ' Setup some point arrays for the Poly* functions ' ReDim PointArrayX(2) As Long ' ReDim PointArrayY(2) As Long ' PointArrayX(0) = 400 ' PointArrayY(0) = 400 ' PointArrayX(1) = 50 ' PointArrayY(1) = 500 ' PointArrayX(2) = 300 ' PointArrayY(2) = 500 ' ' ' Setup the font to use to display text ' Set MyFont = New StdFont ' MyFont.Name = "Times New Roman" ' MyFont.Size = 20 ' MyFont.Bold = True ' MyFont.Italic = True ' MyFont.Underline = False ' MyFont.Strikethrough = False ' ' ' Initialize the class module ' Set Scr = New cScreen ' Scr.EnableRefresh = True ' Scr.BrushHatch = HS_DIAGCROSS ' Scr.BrushSyle = BS_HATCHED ' ' ' Set the background & foreground color for the screen and text ' Scr.BackColor_Scr = vbRed ' Scr.BackColor_Txt = vbYellow ' Scr.ForeColor_Scr = vbGreen ' Scr.ForeColor_Txt = vbBlue ' Set Scr.Font = MyFont ' ' ' Draw text to the screen ' Scr.DrawText "Hello there!!", 0, 0 ' ' ' Draw a picture to the screen ' Scr.DrawPicture 300, 100, "C:\TEST.BMP" ' ' ' Draw an ARC to the screen ' Scr.DrawArc 200, 50, 50, 200, 50, 45, 90 ' ' ' Draw a circle or ellipse to the screen ' Scr.DrawEllipse 150, 150, 250, 250 ' ' ' Draw a half-circle... or "chopped off" circle ' Scr.DrawHalfCircle 0, 300, 100, 400, 0, 300, 100, 300 ' ' ' Draw a line to the screen ' Scr.DrawLine 200, 300, 250, 350 ' ' ' Draw a pie showing the specified percent ' Scr.DrawPie 0, 150, 100, 250, 67 ' ' ' Draw a polygon (multiple sides) to the screen ' Scr.DrawPolygon PointArrayX(), PointArrayY(), 3 ' ' ' Draw a set of lines to the screen ' Scr.DrawPolyline 0, 100, PointArrayX(), PointArrayY(), 3 ' ' ' Draw a square or rectangle to the screen ' Scr.DrawRectangle 500, 10, 600, 60, True, True ' ' End Sub ' '============================================================================================================= ' ' LEGAL: ' ' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit ' given where credit is due. Also, it is not required, but it would be appreciated if you would mention ' somewhere in your compiled program that that your program makes use of code written and distributed by ' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles. ' ' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server ' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products, ' utilities, or applications that directly compete with products, utilities, and applications created by Kevin ' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first ' obtaining the written consent of the author Kevin Wilson. ' ' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without ' warning or notice. Copyright© by Kevin Wilson. All rights reserved. ' '============================================================================================================= Public Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(31) As Byte End Type Private Type FONTSIGNATURE fsUsb(3) As Long fsCsb(1) As Long End Type Private Type ENUMLOGFONT elfLogFont As LOGFONT elfFullName As String * 63 elfStyle As String * 31 End Type Private Type ENUMLOGFONTEX elfLogFont As LOGFONT ' Specifies a LOGFONT structure that contains values defining the font attributes. ' Windows 95/98: If not a TrueType font, the lfFaceName member of LOGFONT is filled with the unique name of the font. elfFullName As String * 63 ' Specifies a null-terminated string specifying the unique name of the font. For example, ABC Font Company TrueType Bold Italic Sans Serif. ' Windows 95/98: Specifies the unique name of a TrueType font. For other type fonts, see explanation in elfLogFont. elfStyle As String * 31 ' Specifies a null-terminated string specifying the style of the font. For example, Bold Italic. elfScript As String * 31 ' Specifies a null-terminated string specifying the script, that is, the character set, of the font. For example, Cyrillic. End Type Private Type TEXTMETRIC tmHeight As Long tmAscent As Long tmDescent As Long tmInternalLeading As Long tmExternalLeading As Long tmAveCharWidth As Long tmMaxCharWidth As Long tmWeight As Long tmOverhang As Long tmDigitizedAspectX As Long tmDigitizedAspectY As Long tmFirstChar As String tmLastChar As String tmDefaultChar As String tmBreakChar As String tmItalic As Byte tmUnderlined As Byte tmStruckOut As Byte tmPitchAndFamily As Byte tmCharSet As Byte End Type Private Type NEWTEXTMETRIC tmHeight As Long tmAscent As Long tmDescent As Long tmInternalLeading As Long tmExternalLeading As Long tmAveCharWidth As Long tmMaxCharWidth As Long tmWeight As Long tmOverhang As Long tmDigitizedAspectX As Long tmDigitizedAspectY As Long tmFirstChar As String tmLastChar As String tmDefaultChar As String tmBreakChar As String tmItalic As Byte tmUnderlined As Byte tmStruckOut As Byte tmPitchAndFamily As Byte tmCharSet As Byte ntmFlags As Long ntmSizeEM As Long ntmCellHeight As Long ntmAvgWidth As Long End Type Private Type NEWTEXTMETRICEX ntmTm As NEWTEXTMETRIC ntmFontSig As FONTSIGNATURE End Type Public s_FontsCount As Long Public s_Fonts() As String Public Function EnumFontFamProc(ByRef lpelf As ENUMLOGFONT, ByRef lpntm As NEWTEXTMETRIC, ByVal FontType As Long, ByVal lParam As Long) As Long ' Add the font to the collection of fonts s_FontsCount = s_FontsCount + 1 ReDim Preserve s_Fonts(s_FontsCount - 1) As String s_Fonts(s_FontsCount - 1) = StrConv(lpelf.elfLogFont.lfFaceName, vbUnicode) s_Fonts(s_FontsCount - 1) = Left(s_Fonts(s_FontsCount - 1), InStr(s_Fonts(s_FontsCount - 1), Chr(0)) - 1) ' Continue the enumeration EnumFontFamProc = 1 End Function ' * NOTE : lpNTME = Pointer to a structure that contains information about the physical ' attributes of a font. The function uses the NEWTEXTMETRICEX structure for ' TrueType fonts, and the TEXTMETRIC structure for other fonts. Use the ' Win32 API "CopyMemory" to copy the correct sructure to a local variable ' using the memory address passed as a LONG to the lpNTME parameter. ' For Windows 2000, this can be an ENUMTEXTMETRIC structure. Public Function EnumFontFamExProc(ByRef lpELFE As ENUMLOGFONTEX, ByRef lpNTME As Long, ByVal FontType As Long, ByVal lParam As Long) As Long ' Add the font to the collection of fonts s_FontsCount = s_FontsCount + 1 ReDim Preserve s_Fonts(s_FontsCount - 1) As String s_Fonts(s_FontsCount - 1) = StrConv(lpELFE.elfLogFont.lfFaceName, vbUnicode) s_Fonts(s_FontsCount - 1) = Left(s_Fonts(s_FontsCount - 1), InStr(s_Fonts(s_FontsCount - 1), Chr(0)) - 1) ' Continue the enumeration EnumFontFamExProc = 1 End Function