VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "cScreen" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '============================================================================================================= ' ' cScreen Class 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 : modScreen.bas (Supporting Standard Module) ' ' Description : This class 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. ' '============================================================================================================= ' Type Declarations Private Type POINT_LNG X As Long Y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Type LOGPEN lopnStyle As Long lopnWidth As POINT_LNG lopnColor As Long End Type Private Type DEVMODE dmDeviceName As String * 32 ' Specifies the the "friendly" name of the printer; for example, "PCL/HP LaserJet" in the case of PCL/HP LaserJet®. This string is unique among device drivers. Note that this name may be truncated to fit in the dmDeviceName array. dmSpecVersion As Integer ' Specifies the version number of the initialization data specification on which the structure is based. To ensure the correct version is used for any operating system, use DM_SPECVERSION. dmDriverVersion As Integer ' Specifies the printer driver version number assigned by the printer driver developer. dmSize As Integer ' Specifies the size, in bytes, of the DEVMODE structure, not including any private driver-specific data that might follow the structure's public members. Set this member to sizeof(DEVMODE) to indicate the version of the DEVMODE structure being used. dmDriverExtra As Integer ' Contains the number of bytes of private driver-data that follow this structure. If a device driver does not use device-specific information, set this member to zero. dmFields As Long ' Specifies whether certain members of the DEVMODE structure have been initialized. If a member is initialized, its corresponding bit is set, otherwise the bit is clear. A printer driver supports only those DEVMODE members that are appropriate for the printer technology. (See DM_* Constants) dmOrientation As Integer ' For printer devices only, selects the orientation of the paper. This member can be either DMORIENT_PORTRAIT (1) or DMORIENT_LANDSCAPE (2). dmPaperSize As Integer ' For printer devices only, selects the size of the paper to print on. This member can be set to zero if the length and width of the paper are both set by the dmPaperLength and dmPaperWidth members. Otherwise, the dmPaperSize member can be set to one of the DMPAPER_* constant values. dmPaperLength As Integer ' For printer devices only, overrides the length of the paper specified by the dmPaperSize member, either for custom paper sizes or for devices such as dot-matrix printers that can print on a page of arbitrary length. These values, along with all other values in this structure that specify a physical length, are in tenths of a millimeter. dmPaperWidth As Integer ' For printer devices only, overrides the width of the paper specified by the dmPaperSize member. dmScale As Integer ' Specifies the factor by which the printed output is to be scaled. The apparent page size is scaled from the physical page size by a factor of dmScale/100. For example, a letter-sized page with a dmScale value of 50 would contain as much data as a page of 17- by 22-inches because the output text and graphics would be half their original height and width. dmCopies As Integer ' Selects the number of copies printed if the device supports multiple-page copies. dmDefaultSource As Integer ' Specifies the paper source. To retrieve a list of the available paper sources for a printer, use the DeviceCapabilities function with the DC_BINS flag. This member can be one of the DMBIN_* constant values, or it can be a device-specific value greater than or equal to DMBIN_USER. dmPrintQuality As Integer ' Specifies the printer resolution. There are four predefined device-independent values : DMRES_HIGH, DMRES_MEDIUM, DMRES_LOW, DMRES_DRAFT dmColor As Integer ' Switches between color and monochrome on color printers. Following are the possible values : DMCOLOR_COLOR, DMCOLOR_MONOCHROME dmDuplex As Integer ' Selects duplex or double-sided printing for printers capable of duplex printing. Following are the possible values : DMDUP_SIMPLEX, DMDUP_HORIZONTAL, DMDUP_VERTICAL dmYResolution As Integer ' Specifies the y-resolution, in dots per inch, of the printer. If the printer initializes this member, the dmPrintQuality member specifies the x-resolution, in dots per inch, of the printer. dmTTOption As Integer ' Specifies how TrueType® fonts should be printed. This member can be one of the following values : DMTT_BITMAP, DMTT_DOWNLOAD, DMTT_DOWNLOAD_OUTLINE, DMTT_SUBDEV dmCollate As Integer ' Specifies whether collation should be used when printing multiple copies. (This member is ignored unless the printer driver indicates support for collation by setting the dmFields member to DM_COLLATE.) This member can be be one of the following values : DMCOLLATE_TRUE (1), DMCOLLATE_FALSE(0) dmFormName As String * 32 ' Windows NT/Windows 2000 : Specifies the name of the form to use; for example, "Letter" or "Legal". A complete set of names can be retrieved by using the EnumForms function. ' Windows 95 : Printer drivers do not use this member. dmLogPixels As Integer ' Specifies the number of pixels per logical inch. Printer drivers do not use this member. dmBitsPerPel As Long ' Specifies the color resolution, in bits per pixel, of the display device (for example: 4 bits for 16 colors, 8 bits for 256 colors, or 16 bits for 65,536 colors). Display drivers use this member, for example, in the ChangeDisplaySettings function. Printer drivers do not use this member. dmPelsWidth As Long ' Specifies the width, in pixels, of the visible device surface. Display drivers use this member, for example, in the ChangeDisplaySettings function. Printer drivers do not use this member. dmPelsHeight As Long ' Specifies the height, in pixels, of the visible device surface. Display drivers use this member, for example, in the ChangeDisplaySettings function. Printer drivers do not use this member. dmDisplayFlags As Long ' Specifies the device's display mode. This member can be a combination of the following values : DM_GRAYSCALE (&H1), DM_INTERLACED (&H2) dmDisplayFrequency As Long ' Specifies the frequency, in hertz (cycles per second), of the display device in a particular mode. This value is also known as the display device's vertical refresh rate. Display drivers use this member. It is used, for example, in the ChangeDisplaySettings function. Printer drivers do not use this member. When you call the EnumDisplaySettings function, the dmDisplayFrequency member may return with the value 0 or 1. These values represent the display hardware's default refresh rate. This default rate is typically set by switches on a display card or computer motherboard, or by a configuration program that does not use Win32 display functions such as ChangeDisplaySettings. dmICMMethod As Long ' Not supported on WinNT : dmICMIntent As Long ' Not supported on WinNT : dmMediaType As Long ' Not supported on WinNT : dmDitherType As Long ' Not supported on WinNT : dmReserved1 As Long ' [Reserved] dmReserved2 As Long ' [Reserved] ' dmPanningWidth As Long ' Windows NT/Windows 2000 : This member must be zero. ' ' Windows 95/98 : This member is not supported. ' dmPanningHeight As Long ' Windows NT/Windows 2000 : This member must be zero. ' ' Windows 95/98 : This member is not supported. End Type Private Type DISPLAY_DEVICE cb As Long ' Size, in bytes, of the DISPLAY_DEVICE structure. This must be initialized prior to calling EnumDisplayDevices. DeviceName As String * 32 ' An array of characters identifying the device name. This is either the adapter device or the monitor device. DeviceString As String * 128 ' An array of characters containing the device context string. This is either a description of the display adapter or of the display monitor. StateFlags As Long ' Device state flags. (See DISPLAY_DEVICE_* Constants) DeviceID As String * 128 ' Windows 98: A string that uniquely identifies the hardware adapter or the monitor. This is the Plug and Play identifier. DeviceKey As String * 128 ' [Reserved] End Type Private Type DRAWTEXTPARAMS cbSize As Long iTabLength As Long iLeftMargin As Long iRightMargin As Long uiLengthDrawn As Long End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Type PicBmp Size As Long Type As Long hBmp As Long hPal As Long Reserved As Long End Type Private Type FontInfo fontName As String PointSize As Long Bold As Boolean Italic As Boolean Underline As Boolean StrikeThru As Boolean End Type ' Enumeration - Text Alignments Public Enum TextAlignments TA_TOP = &H0 TA_LEFT = &H0 TA_CENTER = &H1 TA_RIGHT = &H2 TA_VCENTER = &H4 TA_BOTTOM = &H8 End Enum ' Type - DrawArc Private Type D_ArcInfo daCenterPointX As Long daCenterPointY As Long daRadius As Long daStartPointX As Long daStartPointY As Long daStartAngle As Single daSweepAngle As Single daBckClr_Scr As Long daBckClr_Txt As Long daFreClr_Scr As Long daFreClr_Txt As Long End Type ' Type - DrawEllipse Private Type D_EllipseInfo deTheLeft As Long deTheTop As Long deTheRight As Long deTheBottom As Long deBckClr_Scr As Long deBckClr_Txt As Long deFreClr_Scr As Long deFreClr_Txt As Long End Type ' Type - DrawHalfCircle Private Type D_HalfCircleInfo dhTheLeft As Long dhTheTop As Long dhTheRight As Long dhTheBottom As Long dhX1 As Long dhY1 As Long dhX2 As Long dhY2 As Long dhBckClr_Scr As Long dhBckClr_Txt As Long dhFreClr_Scr As Long dhFreClr_Txt As Long End Type ' Type - DrawLine Private Type D_Line dnStartPointX As Long dnStartPointY As Long dnEndPointX As Long dnEndPointY As Long dnBckClr_Scr As Long dnBckClr_Txt As Long dnFreClr_Scr As Long dnFreClr_Txt As Long End Type ' Type - DrawPicture Private Type D_Picture dpX As Long dpY As Long dpPicturePath As String dpPictureVariable As StdPicture dpPictureHandle As Long dpOutputWidth As Long dpOutputHeight As Long dpStretch As Boolean dpBckClr_Scr As Long dpBckClr_Txt As Long dpFreClr_Scr As Long dpFreClr_Txt As Long End Type ' Type - DrawPie Private Type D_Pie diTheLeft As Long diTheTop As Long diTheRight As Long diTheBottom As Long diPercent As Long diUseCustom As Boolean diCustomX1 As Long diCustomY1 As Long diCustomX2 As Long diCustomY2 As Long diBckClr_Scr As Long diBckClr_Txt As Long diFreClr_Scr As Long diFreClr_Txt As Long End Type ' Type - DrawPolygon Private Type D_Polygon dgPointX_Array() As Long dgPointY_Array() As Long dgPOINT_Count As Long dgBckClr_Scr As Long dgBckClr_Txt As Long dgFreClr_Scr As Long dgFreClr_Txt As Long End Type ' Type - DrawPolyline Private Type D_Polyline dlStartPointX As Long dlStartPointY As Long dlPointX_Array() As Long dlPointY_Array() As Long dlPOINT_Count As Long dlBckClr_Scr As Long dlBckClr_Txt As Long dlFreClr_Scr As Long dlFreClr_Txt As Long End Type ' Type - DrawRectangle Private Type D_Rectangle drTheLeft As Long drTheTop As Long drTheRight As Long drTheBottom As Long drFilled As Boolean drBorder As Boolean drBckClr_Scr As Long drBckClr_Txt As Long drFreClr_Scr As Long drFreClr_Txt As Long End Type ' Type - DrawText Private Type D_Text dtText As String dtTheLeft As Long dtTheTop As Long dtWordWrap As Boolean dtBckClr_Scr As Long dtBckClr_Txt As Long dtFreClr_Scr As Long dtFreClr_Txt As Long End Type ' Constants - Brush Styles Public Enum BrushStyles BS_SOLID = 0 ' Solid brush. BS_NULL = 1 ' Same as BS_HOLLOW. BS_HOLLOW = BS_NULL ' Hollow brush. BS_HATCHED = 2 ' Hatched brush. BS_PATTERN = 3 ' Pattern brush defined by a memory bitmap. BS_INDEXED = 4 ' Indexed brush. BS_DIBPATTERN = 5 ' A pattern brush defined by a device-independent bitmap (DIB) specification. If lbStyle is BS_DIBPATTERN, the lbHatch member contains a handle to a packed DIB. For more information, see discussion in lbHatch. ' Windows 95: Creating brushes from bitmaps or DIBs larger than 8 by 8 pixels is not supported. If a larger bitmap is specified, only a portion of the bitmap is used. BS_DIBPATTERNPT = 6 ' A pattern brush defined by a device-independent bitmap (DIB) specification. If lbStyle is BS_DIBPATTERNPT, the lbHatch member contains a pointer to a packed DIB. For more information, see discussion in lbHatch. BS_PATTERN8X8 = 7 ' Same as BS_PATTERN. BS_DIBPATTERN8X8 = 8 ' Same as BS_DIBPATTERN. BS_MONOPATTERN = 9 ' (Undocumented) End Enum ' Constants - Hatch Styles Public Enum HatchStyles HS_HORIZONTAL = 0 ' [ ----- ] Horizontal hatch HS_VERTICAL = 1 ' [ ||||| ] Vertical hatch HS_FDIAGONAL = 2 ' [ \\\\\ ] A 45-degree downward, left-to-right hatch HS_BDIAGONAL = 3 ' [ ///// ] A 45-degree upward, left-to-right hatch HS_CROSS = 4 ' [ +++++ ] Horizontal and vertical cross-hatch HS_DIAGCROSS = 5 ' [ xxxxx ] 45-degree crosshatch End Enum ' Constants - Pen Styles (Standard) Public Enum PenStyles PS_SOLID = 0 ' The pen is solid. PS_DASH = 1 ' The pen is dashed. This style is valid only when the pen width is one or less in device units. PS_DOT = 2 ' The pen is dotted. This style is valid only when the pen width is one or less in device units. PS_DASHDOT = 3 ' The pen has alternating dashes and dots. This style is valid only when the pen width is one or less in device units. PS_DASHDOTDOT = 4 ' The pen has alternating dashes and double dots. This style is valid only when the pen width is one or less in device units. PS_NULL = 5 ' The pen is invisible. PS_INSIDEFRAME = 6 ' The pen is solid. When this pen is used in any GDI drawing function that takes a bounding rectangle, the dimensions of the figure are shrunk so that it fits entirely in the bounding rectangle, taking into account the width of the pen. This applies only to geometric pens. PS_USERSTYLE = 7 ' Windows NT/2000: The pen uses a styling array supplied by the user. PS_ALTERNATE = 8 ' Windows NT/2000: The pen sets every other pixel. (This style is applicable only for cosmetic pens.) End Enum ' Constants - Color Depths Public Enum ColorDepths BPP_Unknown = 0 ' Unknown color depth BPP_Monocrome = 2 ' Black and White BPP_16_Colors = 4 ' 4 bits for 16 colors BPP_256_Colors = 8 ' 8 bits for 256 colors BPP_65536_Colors = 16 ' 16 bits for 65536 colors BPP_24Bit_Color = 24 ' 24 bits for 24bit Color BPP_True_Color = 32 ' 32 bits for True Color End Enum ' Constants - LoadCursor : Standard Cursor IDs Public Enum Cursors IDC_CUSTOM = 1 ' User-Defined Cursor IDC_ARROW = 32512& ' Standard arrow IDC_IBEAM = 32513& ' Text I-beam IDC_WAIT = 32514& ' Hourglass IDC_CROSS = 32515& ' Crosshair IDC_UPARROW = 32516& ' Vertical arrow IDC_SIZE = 32640& ' Windows NT only: Four-pointed arrow IDC_ICON = 32641& ' Windows NT only: Empty icon IDC_SIZENWSE = 32642& ' Double-pointed arrow pointing northwest and southeast IDC_SIZENESW = 32643& ' Double-pointed arrow pointing northeast and southwest IDC_SIZEWE = 32644& ' Double-pointed arrow pointing west and east IDC_SIZENS = 32645& ' Double-pointed arrow pointing north and south IDC_SIZEALL = 32646& ' Same as IDC_SIZE IDC_NO = 32648& ' Slashed circle ' IDC_HAND = 32649& ' Windows 2000: Hand IDC_APPSTARTING = 32650& ' Standard arrow and small hourglass IDC_HELP = 32651& ' Arrow and question mark End Enum ' Enumeration - Screen Resolutions Public Enum ScreenRes SR_320x240 = 0 SR_640x480 = 1 SR_800x600 = 2 SR_1024x768 SR_1152x864 SR_1280x1024 SR_1600x1200 End Enum ' Enumeration - Screen Color Depths Public Enum ScreenColor SC_NotSpecified = 0 ' Unspecified SC_Monocrome = 2 ' Black and White SC_16_Color = 4 ' 4 bit SC_256_Color = 8 ' 8 bit SC_16Bit_Color = 16 ' 16 bit SC_24Bit_Color = 24 ' 24 bit SC_32Bit_Color = 32 ' 32 bit End Enum ' Constants - OleCreateBitmapIndiect (Return Values) Private Const S_OK = 0 ' The new picture object was created successfully. Private Const E_NOINTERFACE = &H80004002 ' The object does not support the interface specified in riid. Private Const E_POINTER = &H80004003 ' The address in pPictDesc or ppvObj is not valid. For example, it may be NULL. Private Const E_INVALIDARG = &H80000003 ' One or more arguments are invalid Private Const E_OUTOFMEMORY = &H8007000E ' Ran out of memory Private Const E_UNEXPECTED = &H8000FFFF ' Catastrophic failure ' Constants - FormatMessage.dwFlags Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100 ' Specifies that the lpBuffer parameter is a pointer to a PVOID pointer, and that the nSize parameter specifies the minimum number of TCHARs to allocate for an output message buffer. The function allocates a buffer large enough to hold the formatted message, and places a pointer to the allocated buffer at the address specified by lpBuffer. The caller should use the LocalFree function to free the buffer when it is no longer needed. Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200 ' Specifies that insert sequences in the message definition are to be ignored and passed through to the output buffer unchanged. This flag is useful for fetching a message for later formatting. If this flag is set, the Arguments parameter is ignored. Private Const FORMAT_MESSAGE_FROM_STRING = &H400 ' Specifies that lpSource is a pointer to a null-terminated message definition. The message definition may contain insert sequences, just as the message text in a message table resource may. Cannot be used with FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM. Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800 ' Specifies that lpSource is a module handle containing the message-table resource(s) to search. If this lpSource handle is NULL, the current process's application image file will be searched. Cannot be used with FORMAT_MESSAGE_FROM_STRING. Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000 ' Specifies that the function should search the system message-table resource(s) for the requested message. If this flag is specified with FORMAT_MESSAGE_FROM_HMODULE, the function searches the system message table if the message is not found in the module specified by lpSource. Cannot be used with FORMAT_MESSAGE_FROM_STRING. If this flag is specified, an application can pass the result of the GetLastError function to retrieve the message text for a system-defined error. Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000 ' Specifies that the Arguments parameter is not a va_list structure, but instead is just a pointer to an array of values that represent the arguments. ' Constants - Text Formats Private Const DT_TOP = &H0 ' Justifies the text to the top of the rectangle. Private Const DT_LEFT = &H0 ' Aligns text to the left. Private Const DT_CENTER = &H1 ' Centers text horizontally in the rectangle. Private Const DT_RIGHT = &H2 ' Aligns text to the right. Private Const DT_VCENTER = &H4 ' Centers text vertically. This value is used only with the DT_SINGLELINE value. Private Const DT_BOTTOM = &H8 ' Justifies the text to the bottom of the rectangle. This value is used only with the DT_SINGLELINE value. Private Const DT_WORDBREAK = &H10 ' Breaks words. Lines are automatically broken between words if a word would extend past the edge of the rectangle specified by the lpRect parameter. A carriage return-line feed sequence also breaks the line. Private Const DT_SINGLELINE = &H20 ' Displays text on a single line only. Carriage returns and line feeds do not break the line. Private Const DT_EXPANDTABS = &H40 ' Expands tab characters. The default number of characters per tab is eight. The DT_WORD_ELLIPSIS, DT_PATH_ELLIPSIS, and DT_END_ELLIPSIS values cannot be used with the DT_EXPANDTABS value. Private Const DT_TABSTOP = &H80 ' Sets tab stops. Bits 15–8 (high-order byte of the low-order word) of the uFormat parameter specify the number of characters for each tab. The default number of characters per tab is eight. The DT_CALCRECT, DT_EXTERNALLEADING, DT_INTERNAL, DT_NOCLIP, and DT_NOPREFIX values cannot be used with the DT_TABSTOP value. Private Const DT_NOCLIP = &H100 ' Draws without clipping. DrawText is somewhat faster when DT_NOCLIP is used. Private Const DT_EXTERNALLEADING = &H200 ' Includes the font external leading in line height. Normally, external leading is not included in the height of a line of text. Private Const DT_CALCRECT = &H400 ' Determines the width and height of the rectangle. If there are multiple lines of text, DrawText uses the width of the rectangle pointed to by the lpRect parameter and extends the base of the rectangle to bound the last line of text. If there is only one line of text, DrawText modifies the right side of the rectangle so that it bounds the last character in the line. In either case, DrawText returns the height of the formatted text but does not draw the text. Private Const DT_INTERNAL = &H1000 ' Uses the system font to calculate text metrics. Private Const DT_EDITCONTROL = &H2000 ' Duplicates the text-displaying characteristics of a multiline edit control. Specifically, the average character width is calculated in the same manner as for an edit control, and the function does not display a partially visible last line. Private Const DT_PATH_ELLIPSIS = &H2000 ' For displayed text, replaces characters in the middle of the string with ellipses so that the result fits in the specified rectangle. If the string contains backslash (\) characters, DT_PATH_ELLIPSIS preserves as much as possible of the text after the last backslash. The string is not modified unless the DT_MODIFYSTRING flag is specified. Compare with DT_END_ELLIPSIS and DT_WORD_ELLIPSIS. Private Const DT_END_ELLIPSIS = &H8000 ' For displayed text, if the end of a string does not fit in the rectangle, it is truncated and ellipses are added. If a word that is not at the end of the string goes beyond the limits of the rectangle, it is truncated without ellipses. The string is not modified unless the DT_MODIFYSTRING flag is specified. Compare with DT_PATH_ELLIPSIS and DT_WORD_ELLIPSIS. Private Const DT_MODIFYSTRING = &H10000 ' Modifies the specified string to match the displayed text. This value has no effect unless DT_END_ELLIPSIS or DT_PATH_ELLIPSIS is specified. Private Const DT_RTLREADING = &H20000 ' Layout in right-to-left reading order for bi-directional text when the font selected into the hdc is a Hebrew or Arabic font. The default reading order for all text is left-to-right. Private Const DT_WORD_ELLIPSIS = &H40000 ' Truncates any word that does not fit in the rectangle and adds ellipses. Compare with DT_END_ELLIPSIS and DT_PATH_ELLIPSIS. Private Const DT_NOFULLWIDTHCHARBREAK = &H80000 ' Windows 98, Windows 2000: Prevents a line break at a DBCS (double-wide character string), so that the line breaking rule is equivalent to SBCS strings. For example, this can be used in Korean windows, for more readability of icon labels. This value has no effect unless DT_WORDBREAK is specified. Private Const DT_NOPREFIX = &H800 ' Turns off processing of prefix characters. Normally, DrawText interprets the mnemonic-prefix character & as a directive to underscore the character that follows, and the mnemonic-prefix characters && as a directive to print a single &. By specifying DT_NOPREFIX, this processing is turned off. For example, ' Input String : "A&bc&&d" ' Output - Normal : "Abc&d" (b is underlined) ' Output - DT_NOPREFIX : "A&bc&&d" (b is NOT underlined) Private Const DT_HIDEPREFIX = &H100000 ' Windows 2000: Ignores the ampersand (&) prefix character in the text. The letter that follows will not be underlined, but other mnemonic-prefix characters are still processed. For example: ' Input String : "A&bc&&d" ' Output - Normal : "Abc&d" (b is underlined) ' Output - DT_HIDEPREFIX : "Abc&d" (b is NOT underlined) Private Const DT_PREFIXONLY = &H200000 ' Windows 2000: Draws only an underline at the position of the character following the ampersand (&) prefix character. Does not draw any other characters in the string. For example, ' Input String : "A&bc&&d" ' Output - Normal : "Abc&d" (b is underlined) ' Output - DT_PREFIXONLY : " _ " (b is NOT underlined) ' Constants - LoadImage.uType Private Const IMAGE_BITMAP = 0 ' Loads a Bitmap Private Const IMAGE_ICON = 1 ' Loads an Icon Private Const IMAGE_CURSOR = 2 ' Loads a Cursor Private Const IMAGE_ENHMETAFILE = 3 ' Loads a Windows Meta File ' Constants - LoadImage.uFlags Private Const LR_DEFAULTCOLOR = &H0 ' The default flag; it does nothing. All it means is "not LR_MONOCHROME". Private Const LR_MONOCHROME = &H1 ' Loads the image in black and white. Private Const LR_LOADFROMFILE = &H10 ' Loads the image from the file specified by the lpszName parameter. If this flag is not specified, lpszName is the name of the resource. Private Const LR_LOADTRANSPARENT = &H20 ' Retrieves the color value of the first pixel in the image and replaces the corresponding entry in the color table with the default window color (COLOR_WINDOW). All pixels in the image that use that entry become the default window color. This value applies only to images that have corresponding color tables. Do not use this option if you are loading a bitmap with a color depth greater than 8bpp. If fuLoad includes both the LR_LOADTRANSPARENT and LR_LOADMAP3DCOLORS values, LRLOADTRANSPARENT takes precedence. However, the color table entry is replaced with COLOR_3DFACE rather than COLOR_WINDOW. Private Const LR_DEFAULTSIZE = &H40 ' Uses the width or height specified by the system metric values for cursors or icons, if the cxDesired or cyDesired values are set to zero. If this flag is not specified and cxDesired and cyDesired are set to zero, the function uses the actual resource size. If the resource contains multiple images, the function uses the size of the first image. Private Const LR_VGACOLOR = &H80 ' Uses true VGA colors. Private Const LR_CREATEDIBSECTION = &H2000 ' When the uType parameter specifies IMAGE_BITMAP, causes the function to return a DIB section bitmap rather than a compatible bitmap. This flag is useful for loading a bitmap without mapping it to the colors of the display device. Private Const LR_SHARED = &H8000 ' Shares the image handle if the image is loaded multiple times. If LR_SHARED is not set, a second call to LoadImage for the same resource will load the image again and return a different handle. When you use this flag, the system will destroy the resource when it is no longer needed. Do not use LR_SHARED for images that have non-standard sizes, that may change after loading, or that are loaded from a file. ' Windows 95/98: The function finds the first image with the requested resource name in the cache, regardless of the size requested. Private Const LR_LOADMAP3DCOLORS = &H1000 ' Do not use this option if you are loading a bitmap with a color depth greater than 8bpp. Searches the color table for the image and replaces the following shades of gray with the corresponding 3-D color: ' Color: Replaced With: ' --------------------------------------------------- ' Dk Gray - RGB(128,128,128) COLOR_3DSHADOW ' Gray - RGB(192,192,192) COLOR_3DFACE ' Lt Gray - RGB(223,223,223) COLOR_3DLIGHT ' Constants - Image Copy Flags 'Private Const LR_MONOCHROME = &H1 ' Deletes the original image after creating the copy. Private Const LR_COPYRETURNORG = &H4 ' Creates an exact copy of the image, ignoring the cxDesired and cyDesired parameters. Private Const LR_COPYDELETEORG = &H8 ' Creates a new monochrome image. Private Const LR_COPYFROMRESOURCE = &H4000 ' Tries to reload an icon or cursor resource from the original resource file rather than simply copying the current image. This is useful for creating a different-sized copy when the resource file contains multiple sizes of the resource. Without this flag, CopyImage stretches the original image to the new size. If this flag is set, CopyImage uses the size in the resource file closest to the desired size.This will succeed only if hImage was loaded by LoadIcon or LoadCursor, or by LoadImage with the LR_SHARED flag. ' Constants - System Cursor Identifiers Private Const OCR_NORMAL = 32512 ' Normal arrow cursor Private Const OCR_IBEAM = 32513 ' I-beam cursor Private Const OCR_WAIT = 32514 ' Larger hourglass cursor Private Const OCR_CROSS = 32515 ' Crosshair cursor Private Const OCR_UP = 32516 ' Up arrow cursor Private Const OCR_SIZE = 32640 ' Size cursor (OBSOLETE: Use OCR_SIZEALL) Private Const OCR_ICON = 32641 ' Icon cursor (OBSOLETE: Use OCR_NORMAL) Private Const OCR_SIZENWSE = 32642 ' NW to SE sizing cursor Private Const OCR_SIZENESW = 32643 ' NE to SW sizing cursor Private Const OCR_SIZEWE = 32644 ' Horizontal sizing cursor Private Const OCR_SIZENS = 32645 ' Vertical sizing cursor Private Const OCR_SIZEALL = 32646 ' Horizontal and vertical sizing cursor Private Const OCR_ICOCUR = 32647 ' (OBSOLETE: Use OIC_WINLOGO) Private Const OCR_SIZENO = 32648 ' International no symbol cursor Private Const OCR_HAND = 32649 ' Win2000: Hand Private Const OCR_APPSTARTING = 32650 ' Smaller hourglass with arrow cursor 'Private Const OCR_HELP = ? ' Arrow and question mark [ Value Unknown ] ' Constants - SetClassLong Private Const GCL_MENUNAME = (-8) ' Replaces the address of the menu name string. The string identifies the menu resource associated with the class. Private Const GCL_HBRBACKGROUND = (-10) ' Replaces a handle to the background brush associated with the class. Private Const GCL_HCURSOR = (-12) ' Replaces a handle to the cursor associated with the class. Private Const GCL_HICON = (-14) ' Replaces a handle to the icon associated with the class. Private Const GCL_HMODULE = (-16) ' Replaces a handle to the module that registered the class. Private Const GCL_CBWNDEXTRA = (-18) ' Sets the size, in bytes, of the extra window memory associated with each window in the class. Setting this value does not change the number of extra bytes already allocated. For information on how to access this memory, see SetWindowLong. Private Const GCL_CBCLSEXTRA = (-20) ' Sets the size, in bytes, of the extra memory associated with the class. Setting this value does not change the number of extra bytes already allocated. Private Const GCL_WNDPROC = (-24) ' Replaces the address of the window procedure associated with the class. Private Const GCL_STYLE = (-26) ' Replaces the window-class style bits. Private Const GCW_ATOM = (-32) ' (Undocumented) Private Const GCL_HICONSM = (-34) ' Replace a handle to the small icon associated with the class. ' Constants - General Private Const MAX_PATH = 260 ' Constants - EnumDisplaySettings(iModeNum) Private Const ENUM_CURRENT_SETTINGS = (-1) ' Retrieve the current settings for the display device. Private Const ENUM_REGISTRY_SETTINGS = (-2) ' Retrieve the settings for the display device that are currently stored in the registry. ' Constants - DEVMODE.dmFields Private Const DM_ORIENTATION = &H1 'dmOrientation Private Const DM_PAPERSIZE = &H2 'dmPaperSize Private Const DM_PAPERLENGTH = &H4 'dmPaperLength Private Const DM_PAPERWIDTH = &H8 'dmPaperWidth Private Const DM_SCALE = &H10 'dmScale Private Const DM_POSITION = &H20 'dmPosition Private Const DM_COPIES = &H100 'dmCopies Private Const DM_DEFAULTSOURCE = &H200 'dmDefaultSource Private Const DM_PRINTQUALITY = &H400 'dmPrintQuality Private Const DM_COLOR = &H800 'dmColor Private Const DM_DUPLEX = &H1000 'dmDuplex Private Const DM_YRESOLUTION = &H2000 'dmYResolution Private Const DM_TTOPTION = &H4000 'dmTTOption Private Const DM_COLLATE = &H8000 'dmCollate Private Const DM_FORMNAME = &H10000 'dmFormName Private Const DM_LOGPIXELS = &H20000 'dmLogPixels Private Const DM_BITSPERPEL = &H40000 'dmBitsPerPel Private Const DM_PELSWIDTH = &H80000 'dmPelsWidth Private Const DM_PELSHEIGHT = &H100000 'dmPelsHeight Private Const DM_DISPLAYFLAGS = &H200000 'dmDisplayFlags Private Const DM_DISPLAYFREQUENCY = &H400000 'dmDisplayFrequency Private Const DM_ICMMETHOD = &H800000 'dmICMMethod Private Const DM_ICMINTENT = &H1000000 'dmICMIntent Private Const DM_MEDIATYPE = &H2000000 'dmMediaType Private Const DM_DITHERTYPE = &H4000000 'dmDitherType Private Const DM_PANNINGWIDTH = &H8000000 'Windows 2000: dmPanningWidth Private Const DM_PANNINGHEIGHT = &H10000000 'Windows 2000: dmPanningHeight 'Private Const DM_NUP = ? 'dmNup ' Constants - DEVMODE.dmOrientation Private Const DMORIENT_PORTRAIT = 1 Private Const DMORIENT_LANDSCAPE = 2 ' Constants - DEVMODE.dmPrintQuality Private Const DMRES_DRAFT = (-1) Private Const DMRES_LOW = (-2) Private Const DMRES_MEDIUM = (-3) Private Const DMRES_HIGH = (-4) ' Constants - DEVMODE.dmColor Private Const DMCOLOR_MONOCHROME = 1 Private Const DMCOLOR_COLOR = 2 ' Constants - DEVMODE.dmDuplex Private Const DMDUP_SIMPLEX = 1 ' Normal (nonduplex) printing. Private Const DMDUP_VERTICAL = 2 ' Long-edge binding, that is, the long edge of the page is vertical. Private Const DMDUP_HORIZONTAL = 3 ' Short-edge binding, that is, the long edge of the page is horizontal. ' Constants - DEVMODE.dmTTOptions Private Const DMTT_BITMAP = 1 ' Prints TrueType fonts as graphics. This is the default action for dot-matrix printers. Private Const DMTT_DOWNLOAD = 2 ' Downloads TrueType fonts as soft fonts. This is the default action for Hewlett-Packard printers that use Printer Control Language (PCL). Private Const DMTT_SUBDEV = 3 ' Substitutes device fonts for TrueType fonts. This is the default action for PostScript® printers. Private Const DMTT_DOWNLOAD_OUTLINE = 4 ' Window 95/98, Windows NT 4.0, and later: Downloads TrueType fonts as outline soft fonts. ' Constants - DEVMODE.dmDisplayFlags Private Const DM_GRAYSCALE = &H1 ' Specifies that the display is a noncolor device. If this flag is not set, color is assumed. Private Const DM_INTERLACED = &H2 ' Specifies that the display mode is interlaced. If the flag is not set, noninterlaced is assumed. ' Constants - DEVMODE.dmICMMethod Private Const DMICMMETHOD_NONE = 1 'Specifies that ICM is disabled. Private Const DMICMMETHOD_SYSTEM = 2 'Specifies that ICM is handled by Windows. Private Const DMICMMETHOD_DRIVER = 3 'Specifies that ICM is handled by the device driver. Private Const DMICMMETHOD_DEVICE = 4 'Specifies that ICM is handled by the destination device. ' Constants - DEVMODE.dmICMIntent Private Const DMICM_SATURATE = 1 ' Color matching should optimize for color saturation. This value is the most appropriate choice for business graphs when dithering is not desired. Private Const DMICM_CONTRAST = 2 ' Color matching should optimize for color contrast. This value is the most appropriate choice for scanned or photographic images when dithering is desired. Private Const DMICM_COLORMETRIC = 3 ' Color matching should optimize to match the exact color requested. This value is most appropriate for use with business logos or other images when an exact color match is desired. Private Const DMICM_ABS_COLORIMETRIC = 4 ' Color matching should optimize to match the exact color requested without white point mapping. This value is most appropriate for use with proofing. ' Constants - DEVMODE.dmMediaType Private Const DMMEDIA_STANDARD = 1 ' Plain paper. Private Const DMMEDIA_GLOSSY = 2 ' Glossy paper. Private Const DMMEDIA_TRANSPARENCY = 3 ' Transparent film. Private Const DMMEDIA_USER = 256 ' User Devined ' Constants - DEVMODE.DitherType Private Const DMDITHER_NONE = 1 ' No dithering. Private Const DMDITHER_COARSE = 2 ' Dithering with a coarse brush. Private Const DMDITHER_FINE = 3 ' Dithering with a fine brush. Private Const DMDITHER_LINEART = 4 ' Line art dithering, a special dithering method that produces well defined borders between black, white, and gray scalings. It is not suitable for images that include continuous graduations in intensisty and hue, such as scanned photographs. Private Const DMDITHER_GRAYSCALE = 5 ' Device does grayscaling. Private Const DMDITHER_ERRORDIFFUSION = 5 ' Windows 95/98: Dithering in which an algorithm is used to spread, or diffuse, the error of approximating a specified color over adjacent pixels. In contrast, DMDITHER_COARSE, DMDITHER_FINE, and DMDITHER_LINEART use patterned halftoning to approximate a color.. Private Const DMDITHER_USER = 256 ' User Devined ' Constants - ChangeDisplaySettings.dwFlags Private Const CDS_CHANGE = 0 ' The graphics mode for the current screen will be changed dynamically. Private Const CDS_UPDATEREGISTRY = &H1 ' The graphics mode for the current screen will be changed dynamically and the graphics mode will be updated in the registry. The mode information is stored in the USER profile. Private Const CDS_TEST = &H2 ' The system tests if the requested graphics mode could be set. Private Const CDS_FULLSCREEN = &H4 ' The mode is temporary in nature. ' Windows NT/2000: If you change to and from another desktop, this mode will not be reset. Private Const CDS_GLOBAL = &H8 ' The settings will be saved in the global settings area so that they will affect all users on the machine. Otherwise, only the settings for the user are modified. This flag is only valid when specified with the CDS_UPDATEREGISTRY flag. Private Const CDS_SET_PRIMARY = &H10 ' This device will become the primary device. Private Const CDS_RESET = &H40000000 ' The settings should be changed, even if the requested settings are the same as the current settings. Private Const CDS_NORESET = &H10000000 ' The settings will be saved in the registry, but will not take affect. This flag is only valid when specified with the CDS_UPDATEREGISTRY flag. ' Constants - ChangeDisplaySettings (Return Values) Private Const DISP_CHANGE_SUCCESSFUL = 0 ' The settings change was successful. Private Const DISP_CHANGE_RESTART = 1 ' The computer must be restarted in order for the graphics mode to work. Private Const DISP_CHANGE_FAILED = -1 ' The display driver failed the specified graphics mode. Private Const DISP_CHANGE_BADMODE = -2 ' The graphics mode is not supported. Private Const DISP_CHANGE_NOTUPDATED = -3 ' Windows NT/2000: Unable to write settings to the registry. Private Const DISP_CHANGE_BADFLAGS = -4 ' An invalid set of flags was passed in. Private Const DISP_CHANGE_BADPARAM = -5 ' An invalid parameter was passed in. This can include an invalid flag or combination of flags. ' Constants - LOGFONT.lfCharSet Private Const ANSI_CHARSET = 0 Private Const BALTIC_CHARSET = 186 Private Const CHINESEBIG5_CHARSET = 136 Private Const DEFAULT_CHARSET = 1 Private Const EASTEUROPE_CHARSET = 238 Private Const GREEK_CHARSET = 161 Private Const HANGEUL_CHARSET = 129 Private Const MAC_CHARSET = 77 Private Const OEM_CHARSET = 255 Private Const RUSSIAN_CHARSET = 204 Private Const SHIFTJIS_CHARSET = 128 Private Const SYMBOL_CHARSET = 2 Private Const TURKISH_CHARSET = 162 ' Constants - Pen Styles (Extended) Private Const PS_STYLE_MASK = &HF ' (Undocumented) Private Const PS_ENDCAP_MASK = &HF00 ' Pen masked with one of the following end cap values: Private Const PS_ENDCAP_ROUND = &H0 ' Line end caps are round. Private Const PS_ENDCAP_SQUARE = &H100 ' Line end caps are square. Private Const PS_ENDCAP_FLAT = &H200 ' Line end caps are flat. Private Const PS_JOIN_MASK = &HF000 ' Pen masked with one of the following join values: Private Const PS_JOIN_ROUND = &H0 ' Line joins are round. Private Const PS_JOIN_BEVEL = &H1000 ' Line joins are beveled. Private Const PS_JOIN_MITER = &H2000 ' Line joins are mitered when they are within the current limit set by the SetMiterLimit function. A join is beveled when it would exceed the limit. Private Const PS_TYPE_MASK = &HF0000 ' Pen is masked with one of the following pens: Private Const PS_COSMETIC = &H0 ' The pen is cosmetic. Private Const PS_GEOMETRIC = &H10000 ' The pen is geometric. ' Constants - RedrawWindow Private Const RDW_ERASE = &H4 Private Const RDW_FRAME = &H400 Private Const RDW_INTERNALPAINT = &H2 Private Const RDW_INVALIDATE = &H1 Private Const RDW_NOERASE = &H20 Private Const RDW_NOFRAME = &H800 Private Const RDW_NOINTERNALPAINT = &H10 Private Const RDW_VALIDATE = &H8 Private Const RDW_ERASENOW = &H200 Private Const RDW_UPDATENOW = &H100 Private Const RDW_ALLCHILDREN = &H80 Private Const RDW_NOCHILDREN = &H40 ' Constants - GetSystemMetrics Private Const SM_ARRANGE = 56 ' Flags specifying how the system arranged minimized windows. For more information about minimized windows, see the following Remarks section. Private Const SM_CLEANBOOT = 67 ' Value that specifies how the system was started: 0(Normal boot), 1(Fail-safe boot),2(Fail-safe with network boot) ' Fail-safe boot (also called SafeBoot) bypasses the user's startup files. Private Const SM_CMOUSEBUTTONS = 43 ' Number of buttons on mouse, or zero if no mouse is installed. Private Const SM_CXBORDER = 5 ' Width, in pixels, of a window border. This is equivalent to the SM_CXEDGE value for windows with the 3-D look. Private Const SM_CYBORDER = 6 ' Height, in pixels, of a window border. This is equivalent to the SM_CXEDGE value for windows with the 3-D look. Private Const SM_CXCURSOR = 13 ' Width, in pixels, of a cursor. The system cannot create cursors of other sizes. Private Const SM_CYCURSOR = 14 ' Height, in pixels, of a cursor. The system cannot create cursors of other sizes. Private Const SM_CXDLGFRAME = 7 ' (Same as SM_CXFIXEDFRAME) Private Const SM_CYDLGFRAME = 8 ' (Same as SM_CYFIXEDFRAME) Private Const SM_CXDOUBLECLK = 36 ' Width, in pixels, of the rectangle around the location of a first click in a double-click sequence. The second click must occur within this rectangle for the system to consider the two clicks a double-click. (The two clicks must also occur within a specified time.) To set the width and height of the double-click rectangle, call SystemParametersInfo with the SPI_SETDOUBLECLKHEIGHT and SPI_SETDOUBLECLKWIDTH flags. Private Const SM_CYDOUBLECLK = 37 ' Height, in pixels, of the rectangle around the location of a first click in a double-click sequence. The second click must occur within this rectangle for the system to consider the two clicks a double-click. (The two clicks must also occur within a specified time.) To set the width and height of the double-click rectangle, call SystemParametersInfo with the SPI_SETDOUBLECLKHEIGHT and SPI_SETDOUBLECLKWIDTH flags. Private Const SM_CXDRAG = 68 ' Width, in pixels, of a rectangle centered on a drag point to allow for limited movement of the mouse pointer before a drag operation begins. This allows the user to click and release the mouse button easily without unintentionally starting a drag operation. Private Const SM_CYDRAG = 69 ' Height, in pixels, of a rectangle centered on a drag point to allow for limited movement of the mouse pointer before a drag operation begins. This allows the user to click and release the mouse button easily without unintentionally starting a drag operation. Private Const SM_CXEDGE = 45 ' Dimensions, in pixels, of a 3-D border. This is the 3-D counterparts of SM_CXBORDER Private Const SM_CYEDGE = 46 ' Dimensions, in pixels, of a 3-D border. This is the 3-D counterparts of SM_CYBORDER Private Const SM_CXFIXEDFRAME = SM_CXDLGFRAME ' Thickness, in pixels, of the horizontal frame around the perimeter of a window that has a caption but is not sizable. (Same as SM_CXDLGFRAME) Private Const SM_CYFIXEDFRAME = SM_CYDLGFRAME ' Thickness, in pixels, of the vertical frame around the perimeter of a window that has a caption but is not sizable. (Same as SM_CYDLGFRAME) Private Const SM_CXFRAME = 32 ' (Same as SM_CXSIZEFRAME) Private Const SM_CYFRAME = 33 ' (Same as SM_CYSIZEFRAME) Private Const SM_CXFULLSCREEN = 16 ' Width of the client area for a full-screen window on the primary display monitor. To get the coordinates of the portion of the screen not obscured by the system taskbar or by application desktop toolbars, call the SystemParametersInfo function with the SPI_GETWORKAREA value. Private Const SM_CYFULLSCREEN = 17 ' Height of the client area for a full-screen window on the primary display monitor. To get the coordinates of the portion of the screen not obscured by the system taskbar or by application desktop toolbars, call the SystemParametersInfo function with the SPI_GETWORKAREA value. Private Const SM_CXHSCROLL = 21 ' Width, in pixels, of the arrow bitmap on a horizontal scroll bar Private Const SM_CYHSCROLL = 3 ' Height, in pixels, of a horizontal scroll bar. Private Const SM_CXHTHUMB = 10 ' Width, in pixels, of the thumb box in a horizontal scroll bar. Private Const SM_CXICON = 11 ' The default width, in pixels, of an icon. The LoadIcon function can load only icons of these dimensions. Private Const SM_CYICON = 12 ' The default height, in pixels, of an icon. The LoadIcon function can load only icons of these dimensions. Private Const SM_CXICONSPACING = 38 ' Dimensions, in pixels, of a grid cell for items in large icon view. Each item fits into a rectangle of this size when arranged. This value is always greater than or equal to SM_CXICON Private Const SM_CYICONSPACING = 39 ' Dimensions, in pixels, of a grid cell for items in large icon view. Each item fits into a rectangle of this size when arranged. This value is always greater than or equal to SM_CYICON Private Const SM_CXMAXIMIZED = 61 ' Default dimensions, in pixels, of a maximized top-level window on the primary display monitor. Private Const SM_CYMAXIMIZED = 62 ' Default dimensions, in pixels, of a maximized top-level window on the primary display monitor. Private Const SM_CXMAXTRACK = 59 ' Default maximum dimensions, in pixels, of a window that has a caption and sizing borders. This metric refers to the entire desktop. The user cannot drag the window frame to a size larger than these dimensions. A window can override these values by processing the WM_GETMINMAXINFO message. Private Const SM_CYMAXTRACK = 60 ' Default maximum dimensions, in pixels, of a window that has a caption and sizing borders. This metric refers to the entire desktop. The user cannot drag the window frame to a size larger than these dimensions. A window can override these values by processing the WM_GETMINMAXINFO message. Private Const SM_CXMENUCHECK = 71 ' Dimensions, in pixels, of the default menu check-mark bitmap. Private Const SM_CYMENUCHECK = 72 ' Dimensions, in pixels, of the default menu check-mark bitmap. Private Const SM_CXMENUSIZE = 54 ' Dimensions, in pixels, of menu bar buttons, such as the child window close button used in the multiple document interface. Private Const SM_CYMENUSIZE = 55 ' Dimensions, in pixels, of menu bar buttons, such as the child window close button used in the multiple document interface. Private Const SM_CXMIN = 28 ' Minimum width, in pixels, of a window. Private Const SM_CYMIN = 29 ' Minimum height, in pixels, of a window. Private Const SM_CXMINIMIZED = 57 ' Dimensions, in pixels, of a normal minimized window. Private Const SM_CYMINIMIZED = 58 ' Dimensions, in pixels, of a normal minimized window. Private Const SM_CXMINSPACING = 47 ' Dimensions, in pixels, of a grid cell for minimized windows. Each minimized window fits into a rectangle this size when arranged. This value is always greater than or equal to SM_CXMINIMIZED Private Const SM_CYMINSPACING = 48 ' Dimensions, in pixels, of a grid cell for minimized windows. Each minimized window fits into a rectangle this size when arranged. This value is always greater than or equal to SM_CYMINIMIZED Private Const SM_CXMINTRACK = 34 ' Minimum tracking width, in pixels, of a window. The user cannot drag the window frame to a size smaller than these dimensions. A window can override these values by processing the WM_GETMINMAXINFO message. Private Const SM_CYMINTRACK = 35 ' Minimum tracking height, in pixels, of a window. The user cannot drag the window frame to a size smaller than these dimensions. A window can override these values by processing the WM_GETMINMAXINFO message. Private Const SM_CXSCREEN = 0 ' Width, in pixels, of the screen of the primary display monitor. These are the same values you obtain by calling GetDeviceCaps(hdcPrimaryMonitor, HORZRES/VERTRES). Private Const SM_CYSCREEN = 1 ' Height, in pixels, of the screen of the primary display monitor. These are the same values you obtain by calling GetDeviceCaps(hdcPrimaryMonitor, HORZRES/VERTRES). Private Const SM_CXSIZE = 30 ' Width, in pixels, of a button in a window's caption or title bar. Private Const SM_CYSIZE = 31 ' Height, in pixels, of a button in a window's caption or title bar. Private Const SM_CXSIZEFRAME = SM_CXFRAME ' Thickness, in pixels, of the horizontal sizing border around the perimeter of a window that can be resized. Same as SM_CXFRAME Private Const SM_CYSIZEFRAME = SM_CYFRAME ' Thickness, in pixels, of the vertical sizing border around the perimeter of a window that can be resized. Same as SM_CYFRAME Private Const SM_CXSMICON = 49 ' Recommended dimensions, in pixels, of a small icon. Small icons typically appear in window captions and in small icon view. Private Const SM_CYSMICON = 50 ' Recommended dimensions, in pixels, of a small icon. Small icons typically appear in window captions and in small icon view. Private Const SM_CXSMSIZE = 52 ' Dimensions, in pixels, of small caption buttons. Private Const SM_CYSMSIZE = 53 ' Dimensions, in pixels, of small caption buttons. Private Const SM_CXVSCROLL = 2 ' Width, in pixels, of a vertical scroll bar Private Const SM_CYVSCROLL = 20 ' Height, in pixels, of the arrow bitmap on a vertical scroll bar. Private Const SM_CYCAPTION = 4 ' Height, in pixels, of a normal caption area. Private Const SM_CYKANJIWINDOW = 18 ' For double byte character set versions of the system, this is the height, in pixels, of the Kanji window at the bottom of the screen. Private Const SM_CYMENU = 15 ' Height, in pixels, of a single-line menu bar. Private Const SM_CYSMCAPTION = 51 ' Height, in pixels, of a small caption. Private Const SM_CYVTHUMB = 9 ' Height, in pixels, of the thumb box in a vertical scroll bar. Private Const SM_DBCSENABLED = 42 ' TRUE or nonzero if the double-byte character-set (DBCS) version of User.exe is installed; FALSE or zero otherwise. Private Const SM_DEBUG = 22 ' TRUE or nonzero if the debugging version of User.exe is installed; FALSE or zero otherwise. Private Const SM_MENUDROPALIGNMENT = 40 ' TRUE or nonzero if drop-down menus are right-aligned with the corresponding menu-bar item; FALSE or zero if the menus are left-aligned. Private Const SM_MIDEASTENABLED = 74 ' TRUE if the system is enabled for Hebrew and Arabic languages. Private Const SM_MOUSEPRESENT = 19 ' TRUE or nonzero if a mouse is installed; FALSE or zero otherwise. Private Const SM_NETWORK = 63 ' The least significant bit is set if a network is present; otherwise, it is cleared. The other bits are reserved for future use. Private Const SM_PENWINDOWS = 41 ' TRUE or nonzero if the Microsoft Windows for Pen computing extensions are installed; FALSE or zero otherwise. Private Const SM_SECURE = 44 ' TRUE if security is present; FALSE otherwise. Private Const SM_SHOWSOUNDS = 70 ' TRUE or nonzero if the user requires an application to present information visually in situations where it would otherwise present the information only in audible form; FALSE, or zero, otherwise. Private Const SM_SLOWMACHINE = 73 ' TRUE if the computer has a low-end (slow) processor; FALSE otherwise. Private Const SM_SWAPBUTTON = 23 ' TRUE or nonzero if the meanings of the left and right mouse buttons are swapped; FALSE or zero otherwise. '-------------------------------------- Private Const SM_MOUSEWHEELPRESENT = 75 ' Not Supported On Win95 : TRUE or nonzero if a mouse with a wheel is installed; FALSE or zero otherwise. Private Const SM_CMONITORS = 80 ' Windows 98, Windows 2000 : Number of display monitors on the desktop. See Remarks for more information. Private Const SM_CXVIRTUALSCREEN = 78 ' Windows 98, Windows 2000 : Width and height, in pixels, of the virtual screen. The virtual screen is the bounding rectangle of all display monitors. The SM_XVIRTUALSCREEN, SM_YVIRTUALSCREEN metrics are the coordinates of the top-left corner of the virtual screen. Private Const SM_CYVIRTUALSCREEN = 79 ' Windows 98, Windows 2000 : Width and height, in pixels, of the virtual screen. The virtual screen is the bounding rectangle of all display monitors. The SM_XVIRTUALSCREEN, SM_YVIRTUALSCREEN metrics are the coordinates of the top-left corner of the virtual screen. Private Const SM_SAMEDISPLAYFORMAT = 81 ' Windows 98, Windows 2000 : TRUE if all the display monitors have the same color format, FALSE otherwise. Note that two displays can have the same bit depth, but different color formats. For example, the red, green, and blue pixels can be encoded with different numbers of bits, or those bits can be located in different places in a pixel's color value. Private Const SM_XVIRTUALSCREEN = 76 ' Windows 98, Windows 2000 : Coordinates for the left side and the top of the virtual screen. The virtual screen is the bounding rectangle of all display monitors. The SM_CXVIRTUALSCREEN, SM_CYVIRTUALSCREEN metrics are the width and height of the virtual screen. Private Const SM_YVIRTUALSCREEN = 77 ' Windows 98, Windows 2000 : Coordinates for the left side and the top of the virtual screen. The virtual screen is the bounding rectangle of all display monitors. The SM_CXVIRTUALSCREEN, SM_CYVIRTUALSCREEN metrics are the width and height of the virtual screen. 'Private Const SM_REMOTESESSION = ? ' WinNT 4.0 (SP4) or later : This system metric is used in a Terminal Services environment. If the calling process is associated with a Terminal Services client session, the return value is TRUE or nonzero. If the calling process is associated with the Terminal Server console session, the return value is zero. ' Constants - BitBlt.dwRasterOperations '------------------------------------------------------------------------ '#define SRCCOPY (DWORD)0x00CC0020 // dest = source '#define SRCPAINT (DWORD)0x00EE0086 // dest = source OR dest '#define SRCAND (DWORD)0x008800C6 // dest = source AND dest '#define SRCINVERT (DWORD)0x00660046 // dest = source XOR dest '#define SRCERASE (DWORD)0x00440328 // dest = source AND (NOT dest ) '#define NOTSRCCOPY (DWORD)0x00330008 // dest = (NOT source) '#define NOTSRCERASE (DWORD)0x001100A6 // dest = (NOT src) AND (NOT dest) '#define MERGECOPY (DWORD)0x00C000CA // dest = (source AND pattern) '#define MERGEPAINT (DWORD)0x00BB0226 // dest = (NOT source) OR dest '#define PATCOPY (DWORD)0x00F00021 // dest = pattern '#define PATPAINT (DWORD)0x00FB0A09 // dest = DPSnoo '#define PATINVERT (DWORD)0x005A0049 // dest = pattern XOR dest '#define DSTINVERT (DWORD)0x00550009 // dest = (NOT dest) '#define BLACKNESS (DWORD)0x00000042 // dest = BLACK '#define WHITENESS (DWORD)0x00FF0062 // dest = WHITE '#define NOMIRRORBITMAP (DWORD)0x80000000 // Do not Mirror the bitmap in this call '#define CAPTUREBLT (DWORD)0x40000000 // Include layered windows '------------------------------------------------------------------------ Private Const SRCCOPY = &HCC0020 ' Copies the source rectangle directly to the destination rectangle. Private Const SRCPAINT = &HEE0086 ' Combines the colors of the source and destination rectangles by using the Boolean OR operator. Private Const SRCAND = &H8800C6 ' Combines the colors of the source and destination rectangles by using the Boolean AND operator. Private Const SRCINVERT = &H660046 ' Combines the colors of the source and destination rectangles by using the Boolean XOR operator. Private Const SRCERASE = &H440328 ' Combines the inverted colors of the destination rectangle with the colors of the source rectangle by using the Boolean AND operator. Private Const NOTSRCCOPY = &H330008 ' Copies the inverted source rectangle to the destination. Private Const NOTSRCERASE = &H1100A6 ' Combines the colors of the source and destination rectangles by using the Boolean OR operator and then inverts the resultant color. Private Const MERGECOPY = &HC000CA ' Merges the colors of the source rectangle with the brush currently selected in hdcDest, by using the Boolean AND operator. Private Const MERGEPAINT = &HBB0226 ' Merges the colors of the inverted source rectangle with the colors of the destination rectangle by using the Boolean OR operator. Private Const PATCOPY = &HF00021 ' Copies the brush currently selected in hdcDest, into the destination bitmap. Private Const PATPAINT = &HFB0A09 ' Combines the colors of the brush currently selected in hdcDest, with the colors of the inverted source rectangle by using the Boolean OR operator. The result of this operation is combined with the colors of the destination rectangle by using the Boolean OR operator. Private Const PATINVERT = &H5A0049 ' Combines the colors of the brush currently selected in hdcDest, with the colors of the destination rectangle by using the Boolean XOR operator. Private Const DSTINVERT = &H550009 ' Inverts the destination rectangle. Private Const BLACKNESS = &H42 ' Fills the destination rectangle using the color associated with index 0 in the physical palette. (This color is black for the default physical palette.) Private Const WHITENESS = &HFF0062 ' Fills the destination rectangle using the color associated with index 1 in the physical palette. (This color is white for the default physical palette.) Private Const NOMIRRORBITMAP = &H80000000 ' Windows 98, Windows 2000: Prevents the bitmap from being mirrored. Private Const CAPTUREBLT = &H40000000 ' Windows 98, Windows 2000: Includes any windows that are layered on top of your window in the resulting image. By default, the image only contains your window. ' Constants - GetDeviceCaps Private Const HORZSIZE = 4 Private Const VERTSIZE = 6 Private Const HORZRES = 8 Private Const VERTRES = 10 Private Const BITSPIXEL = 12 Private Const LOGPIXELSX = 88 Private Const LOGPIXELSY = 90 Private Const COLORRES = 108 ' Property Defaults Private Const DEF_BrushStyle = BS_SOLID Private Const DEF_BrushHatch = HS_FDIAGONAL Private Const DEF_PenStyle = PS_SOLID Private Const DEF_PenWidth = 1 Private Const DEF_BackColor = vbWhite Private Const DEF_ForeColor = vbBlack Private Const DEF_FontName = "Arial" Private Const DEF_FontSize = 10 Private Const DEF_EnableRefresh = False ' Handle to the screen Private ScreenHWND As Long ' Refresh Tracking Variables Private RefreshingDisplay As Boolean '------ Private DArcInfo() As D_ArcInfo Private DEllipseInfo() As D_EllipseInfo Private DHalfCircleInfo() As D_HalfCircleInfo Private DLine() As D_Line Private DPicture() As D_Picture Private DPie() As D_Pie Private DPolygon() As D_Polygon Private DPolyline() As D_Polyline Private DRectangle() As D_Rectangle Private DText() As D_Text '------ Private DArcInfoCount As Long Private DEllipseInfoCount As Long Private DHalfCircleInfoCount As Long Private DLineCount As Long Private DPictureCount As Long Private DPieCount As Long Private DPolygonCount As Long Private DPolylineCount As Long Private DRectangleCount As Long Private DTextCount As Long ' Property Variables Private s_Font As FontInfo Private s_MouseIcon As String Private s_BrushStyle As BrushStyles Private s_BrushHatch As HatchStyles Private s_PenStyle As PenStyles Private s_PenWidth As Long Private s_BackColor_Scr As Long Private s_ForeColor_Scr As Long Private s_BackColor_Txt As Long Private s_ForeColor_Txt As Long Private s_DeviceCount As Long Private s_DeviceName() As String Private s_DeviceStr() As String Private s_BitsPerPixel As Long Private s_Height As Single Private s_Width As Single Private s_TwipsX As Single Private s_TwipsY As Single Private s_PreviousCursor As Long Private s_EnableRefresh As Boolean ' Win32 API Declarations Private Declare Function AttachThreadInput Lib "USER32" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long Private Declare Function ChangeDisplaySettings Lib "USER32" Alias "ChangeDisplaySettingsA" (ByRef lpDevMode As DEVMODE, ByVal dwFlags As Long) As Long Private Declare Function CreateBrushIndirect Lib "gdi32" (ByRef lpLOGBRUSH As LOGBRUSH) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal FontHeight As Long, ByVal Avg_CharWidth As Long, ByVal EscapementAngle As Long, ByVal OrientationAngle As Long, ByVal FontWeight As Long, ByVal Italic As Long, ByVal Underline As Long, ByVal StrikeOut As Long, ByVal CharSetID As Long, ByVal OutputPrecision As Long, ByVal ClipPrecision As Long, ByVal Quality As Long, ByVal PitchAndFamily As Long, ByVal fontName As String) As Long Private Declare Function CreatePen Lib "gdi32" (ByVal fnPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long Private Declare Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function DestroyCursor Lib "USER32" (ByVal hCursor As Long) As Long Private Declare Function DRAW_Arc Lib "gdi32" Alias "AngleArc" (ByVal hDC As Long, ByVal CenterPointX As Long, ByVal CenterPointY As Long, ByVal dwRadius As Long, ByVal eStartAngle As Single, ByVal eSweepAngle As Single) As Long Private Declare Function DRAW_DrawText Lib "USER32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long Private Declare Function DRAW_Ellipse Lib "gdi32" Alias "Ellipse" (ByVal hDC As Long, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long) As Long Private Declare Function DRAW_HalfCircle Lib "gdi32" Alias "Chord" (ByVal hDC As Long, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long, ByVal nXRadial1 As Long, ByVal nYRadial1 As Long, ByVal nXRadial2 As Long, ByVal nYRadial2 As Long) As Long Private Declare Function DRAW_Line Lib "gdi32" Alias "LineTo" (ByVal hDC As Long, ByVal EndPointX As Long, ByVal EndPointY As Long) As Long Private Declare Function DRAW_MoveCurrentXY Lib "gdi32" Alias "MoveToEx" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByRef OldPoint_POINT As Any) As Long Private Declare Function DRAW_Picture Lib "gdi32" Alias "BitBlt" (ByVal hDC_Dest As Long, ByVal X_Dest As Long, ByVal Y_Dest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDC_Src As Long, ByVal X_Src As Long, ByVal Y_Src As Long, ByVal dwRasterOperation As Long) As Long Private Declare Function DRAW_PictureStretch Lib "gdi32" Alias "StretchBlt" (ByVal hDC_Dest As Long, ByVal X_Dest As Long, ByVal Y_Dest As Long, ByVal nWidth_Output As Long, ByVal nHeight_Output As Long, ByVal hDC_Src As Long, ByVal X_Src As Long, ByVal Y_Src As Long, ByVal nWidth_Original As Long, ByVal nHeight_Original As Long, ByVal dwRasterOperation As Long) As Long Private Declare Function DRAW_Pie Lib "gdi32" Alias "Pie" (ByVal hDC As Long, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long, ByVal nRadial1_X As Long, ByVal nRadial1_Y As Long, ByVal nRadial2_X As Long, ByVal nRadial2_Y As Long) As Long Private Declare Function DRAW_Polygon Lib "gdi32" Alias "Polygon" (ByVal hDC As Long, ByRef POINT_Array As POINT_LNG, ByVal POINT_Count As Long) As Long Private Declare Function DRAW_Polyline Lib "gdi32" Alias "PolylineTo" (ByVal hDC As Long, ByRef POINT_Array As POINT_LNG, ByVal POINT_Count As Long) As Long Private Declare Function DRAW_RectangleFilled Lib "USER32" Alias "FillRect" (ByVal hDC As Long, lpRect As RECT, ByVal hBRUSH As Long) As Long Private Declare Function DRAW_RectangleOutline Lib "USER32" Alias "FrameRect" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBRUSH As Long) As Long Private Declare Function EnumDisplayDevices Lib "USER32" Alias "EnumDisplayDevicesA" (ByVal lpDevice As String, ByVal iDevNum As Long, ByRef lpDisplayDevice As DISPLAY_DEVICE, ByVal dwFlags As Long) As Long Private Declare Function EnumDisplaySettings Lib "USER32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, ByRef lpDevMode As DEVMODE) As Long Private Declare Function EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" (ByVal hDC As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, ByVal lParam As Long) As Long Private Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hDC As Long, ByRef lpLogFont As LOGFONT, ByVal lpEnumFontFamExProc As Long, ByVal lParam As Long, ByVal dwFlags As Long) As Long Private Declare Function FormatMessage Lib "KERNEL32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long Private Declare Function GetActiveWindow Lib "USER32" () As Long Private Declare Function GetClassLong Lib "USER32" Alias "GetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function GetCurrentThreadId Lib "KERNEL32" () As Long Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long Private Declare Function GetDesktopWindow Lib "USER32" () As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long Private Declare Function GetFocus Lib "USER32" () As Long Private Declare Function GetForegroundWindow Lib "USER32" () As Long Private Declare Function GetSystemMetrics Lib "USER32" (ByVal nIndex As Long) As Long Private Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long Private Declare Function GetWindowThreadProcessId Lib "USER32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long Private Declare Function LoadCursor Lib "USER32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long Private Declare Function LoadCursorFromFile Lib "USER32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long Private Declare Function LoadImageSTR Lib "USER32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpszFileName As String, ByVal uImageType As Long, ByVal OutputWidth As Long, ByVal OutputHeight As Long, ByVal uFlags As Long) As Long Private Declare Function MulDiv Lib "KERNEL32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (ByRef PicDesc As PicBmp, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As StdPicture) As Long 'As IPicture) As Long Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pColorRef As Long) As Long Private Declare Function RedrawWindow Lib "USER32" (ByVal hWnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hGDIObj As Long) As Long Private Declare Function SetClassLong Lib "USER32" Alias "SetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetTextBackColor Lib "gdi32" Alias "SetBkColor" (ByVal hDC As Long, ByVal crColor As Long) As Long Private Declare Function SetTextForeColor Lib "gdi32" Alias "SetTextColor" (ByVal hDC As Long, ByVal crColor As Long) As Long Private Declare Function WindowFromDC Lib "USER32" (ByVal hDC As Long) As Long '================================================================================================== ' CLASS EVENTS '================================================================================================== Private Sub Class_Initialize() Dim ScreenHDC As Long Dim hFont As Long ' Set the default Pen and Brush information s_BrushHatch = DEF_BrushHatch s_BrushStyle = DEF_BrushStyle s_PenStyle = DEF_PenStyle s_PenWidth = DEF_PenWidth s_BackColor_Scr = DEF_BackColor s_BackColor_Txt = DEF_BackColor s_ForeColor_Scr = DEF_ForeColor s_ForeColor_Txt = DEF_ForeColor s_Font.fontName = DEF_FontName s_Font.PointSize = DEF_FontSize s_EnableRefresh = DEF_EnableRefresh ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Get the information about the screen, etc. RefreshDisplayInfo ScreenHDC ' Set the foreground and background for the screen SetColors ScreenHDC ' Set the screen's font If GetFont(ScreenHDC, s_Font, hFont) = True Then SetDisplayFont ScreenHDC, hFont End If ' Free the temporary DC ReleaseDC ScreenHWND, ScreenHDC End Sub Private Sub Class_Terminate() On Error Resume Next ' Clear the screen Clear ' Delete all record of previously drawn items DeleteDrawInfo End Sub '================================================================================================== ' CLASS METHODS '================================================================================================== ' Changes the current resolution Public Function ChangeResolution(ByVal ScreenSize As ScreenRes, Optional ByVal ScreenColorDepth As ScreenColor = SC_NotSpecified, Optional ByRef Return_RestartRequired As Boolean, Optional ByVal TestSettings As Boolean = False) As Boolean Dim NewHeight As Long Dim NewWidth As Long Dim DevM As DEVMODE Dim TheFlags As Long Dim ScreenHDC As Long Dim ReturnValue As Long ' The following are the fields in the DEVMODE structure that are used for changing display settings '---------------------------------------------------------------------------------------------------- ' DEVMODE Member: DEVMODE.dmFields: Description: '---------------------------------------------------------------------------------------------------- ' dmBitsPerPel - DM_BITSPERPEL - Bits per pixel ' dmPelsWidth - DM_PELSWIDTH - Pixel width ' dmPelsHeight - DM_PELSHEIGHT - Pixel height ' dmDisplayFlags - DM_DISPLAYFLAGS - Mode flags ' dmDisplayFrequency - DM_DISPLAYFREQUENCY - Mode frequency ' dmPosition - DM_POSITION - Windows 98, Windows 2000: Position of the device in a multimonitor configuration '---------------------------------------------------------------------------------------------------- ' Set the initial DEVMODE members DevM.dmSize = Len(DevM) If ScreenColorDepth <> SC_NotSpecified Then DevM.dmFields = DM_PELSHEIGHT Or DM_PELSWIDTH Or DM_BITSPERPEL Else DevM.dmFields = DM_PELSHEIGHT Or DM_PELSWIDTH End If ' Get the height/width based on the user's selection Select Case ScreenSize Case SR_320x240 NewWidth = 320 NewHeight = 240 GoSub CheckResolution DevM.dmPelsWidth = 320 DevM.dmPelsHeight = 240 Case SR_640x480 NewWidth = 640 NewHeight = 480 GoSub CheckResolution DevM.dmPelsWidth = 640 DevM.dmPelsHeight = 480 Case SR_800x600 NewWidth = 800 NewHeight = 600 GoSub CheckResolution DevM.dmPelsWidth = 800 DevM.dmPelsHeight = 600 Case SR_1024x768 NewWidth = 1024 NewHeight = 768 GoSub CheckResolution DevM.dmPelsWidth = 1024 DevM.dmPelsHeight = 768 Case SR_1152x864 NewWidth = 1152 NewHeight = 864 GoSub CheckResolution DevM.dmPelsWidth = 1152 DevM.dmPelsHeight = 864 Case SR_1280x1024 NewWidth = 1280 NewHeight = 1024 GoSub CheckResolution DevM.dmPelsWidth = 1280 DevM.dmPelsHeight = 1024 Case SR_1600x1200 NewWidth = 1600 NewHeight = 1200 GoSub CheckResolution DevM.dmPelsWidth = 1600 DevM.dmPelsHeight = 1200 End Select ' Set the color depth of the screen If ScreenColorDepth <> SC_NotSpecified Then DevM.dmBitsPerPel = CLng(ScreenColorDepth) End If ' Set the proper flags If TestSettings = True Then TheFlags = CDS_TEST Else TheFlags = CDS_CHANGE Or CDS_UPDATEREGISTRY Or CDS_RESET End If ' Get a handle to the screen DC ScreenHDC = Me.hDC ' Call the API to change the resolution ReturnValue = ChangeDisplaySettings(DevM, TheFlags) If ReturnValue = DISP_CHANGE_SUCCESSFUL Then Return_RestartRequired = False ChangeResolution = True GetDisplayInfo ScreenHDC ElseIf ReturnValue = DISP_CHANGE_RESTART Then Return_RestartRequired = True ChangeResolution = True GetDisplayInfo ScreenHDC Else Return_RestartRequired = False GoTo ReportError End If CleanUp: ' Release the temporary DC handle ReleaseDC ScreenHWND, ScreenHDC Exit Function CheckResolution: ' Check if the resolution is the same If ScreenColorDepth = SC_NotSpecified Then If Me.Width = NewWidth And Me.Height = NewHeight Then ChangeResolution = True Exit Function End If Else If Me.Width = NewWidth And Me.Height = NewHeight And CLng(Me.BitsPerPixel) = CLng(ScreenColorDepth) Then ChangeResolution = True Exit Function End If End If Return ReportError: ' Get the return error Select Case ReturnValue Case DISP_CHANGE_FAILED ErrorHandler App.EXEName & "cScreen.ChangeResolution(ChangeDisplaySettings)", DISP_CHANGE_FAILED, "The display driver failed the specified graphics mode." Case DISP_CHANGE_BADMODE ErrorHandler App.EXEName & "cScreen.ChangeResolution(ChangeDisplaySettings)", DISP_CHANGE_BADMODE, "The graphics mode is not supported." Case DISP_CHANGE_NOTUPDATED ErrorHandler App.EXEName & "cScreen.ChangeResolution(ChangeDisplaySettings)", DISP_CHANGE_NOTUPDATED, "Unable to write settings to the registry." Case DISP_CHANGE_BADFLAGS ErrorHandler App.EXEName & "cScreen.ChangeResolution(ChangeDisplaySettings)", DISP_CHANGE_BADFLAGS, "An invalid set of flags was passed in." Case DISP_CHANGE_BADPARAM ErrorHandler App.EXEName & "cScreen.ChangeResolution(ChangeDisplaySettings)", DISP_CHANGE_BADPARAM, "An invalid parameter was passed in. This can include an invalid flag or combination of flags." Case Else ErrorHandler App.EXEName & "cScreen.ChangeResolution(ChangeDisplaySettings)", -1, "An unknown error occured while trying to change the screen resolution." End Select GoTo CleanUp End Function ' This function clears anything drawn on the display screen Public Function Clear(Optional ClearRefreshCache As Boolean = True) As Boolean On Error Resume Next ' Make sure screen handle is valid If ScreenHWND = 0 Then Exit Function ' Clear the screen by making the display area invalid If RedrawWindow(ScreenHWND, ByVal 0, 0, RDW_INVALIDATE Or RDW_ALLCHILDREN) <> 0 Then ' Delete all record of previously drawn items If ClearRefreshCache = True Then DeleteDrawInfo End If Clear = True End If DoEvents End Function ' Draws a line segment and an arc. The line segment is drawn from the current position to ' the beginning of the arc. The arc is drawn along the perimeter of a circle with the ' given radius and center. The length of the arc is defined by the given start and sweep ' angles. Public Function DrawArc(ByVal CenterPointX As Long, _ ByVal CenterPointY As Long, _ ByVal Radius As Long, _ ByVal StartPointX As Long, _ ByVal StartPointY As Long, _ ByVal StartAngle As Single, _ ByVal SweepAngle As Single) As Boolean On Error Resume Next Dim ScreenHDC As Long ' Make sure parameters are valid If Radius < 1 Then ErrorHandler App.EXEName & ".cScreen.DrawArc", -1, "Invalid Radius Specified" Exit Function End If ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Set the background and foreground colors for the screen DC SetColors ScreenHDC ' Set the start point If Me.SetCurrentXY(ScreenHDC, StartPointX, StartPointY) = False Then Exit Function End If ' Draw the arc If DRAW_Arc(ScreenHDC, CenterPointX, CenterPointY, Radius, StartAngle, SweepAngle) <> 0 Then DrawArc = True Else ErrorHandler App.EXEName & ".cScreen.DrawArc(DRAW_Arc)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Free the temp DC ReleaseDC ScreenHWND, ScreenHDC ' Record the draw item for refresh ability If RefreshingDisplay = False And s_EnableRefresh = True Then DArcInfoCount = DArcInfoCount + 1 ReDim Preserve DArcInfo(DArcInfoCount) As D_ArcInfo DArcInfo(DArcInfoCount).daCenterPointX = CenterPointX DArcInfo(DArcInfoCount).daCenterPointY = CenterPointY DArcInfo(DArcInfoCount).daRadius = Radius DArcInfo(DArcInfoCount).daStartAngle = StartAngle DArcInfo(DArcInfoCount).daStartPointX = StartPointX DArcInfo(DArcInfoCount).daStartPointY = StartPointY DArcInfo(DArcInfoCount).daSweepAngle = SweepAngle DArcInfo(DArcInfoCount).daBckClr_Scr = s_BackColor_Scr DArcInfo(DArcInfoCount).daBckClr_Txt = s_BackColor_Txt DArcInfo(DArcInfoCount).daFreClr_Scr = s_ForeColor_Scr DArcInfo(DArcInfoCount).daFreClr_Txt = s_ForeColor_Txt End If DoEvents End Function ' Draws an ellipse. The center of the ellipse is the center of the specified bounding rectangle. ' The ellipse is outlined by using the current pen and is filled by using the current brush. Public Function DrawEllipse(ByVal TheLeft As Long, _ ByVal TheTop As Long, _ ByVal TheRight As Long, _ ByVal TheBottom As Long) As Boolean On Error Resume Next Dim ScreenHDC As Long ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Set the background and foreground colors for the screen DC SetColors ScreenHDC ' Draw the ellipse If DRAW_Ellipse(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom) <> 0 Then DrawEllipse = True Else ErrorHandler App.EXEName & ".cScreen.DrawEllipse(DRAW_Ellipse)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Free the temp DC ReleaseDC ScreenHWND, ScreenHDC ' Record the draw item for refresh ability If RefreshingDisplay = False And s_EnableRefresh = True Then DEllipseInfoCount = DEllipseInfoCount + 1 ReDim Preserve DEllipseInfo(DEllipseInfoCount) As D_EllipseInfo DEllipseInfo(DEllipseInfoCount).deTheBottom = TheBottom DEllipseInfo(DEllipseInfoCount).deTheLeft = TheLeft DEllipseInfo(DEllipseInfoCount).deTheRight = TheRight DEllipseInfo(DEllipseInfoCount).deTheTop = TheTop DEllipseInfo(DEllipseInfoCount).deBckClr_Scr = s_BackColor_Scr DEllipseInfo(DEllipseInfoCount).deBckClr_Txt = s_BackColor_Txt DEllipseInfo(DEllipseInfoCount).deFreClr_Scr = s_ForeColor_Scr DEllipseInfo(DEllipseInfoCount).deFreClr_Txt = s_ForeColor_Txt End If DoEvents End Function ' Draws a chord (a region bounded by the intersection of an ellipse and a line segment, called a secant). ' The chord is outlined by using the current pen and filled by using the current brush. Public Function DrawHalfCircle(ByVal TheLeft As Long, _ ByVal TheTop As Long, _ ByVal TheRight As Long, _ ByVal TheBottom As Long, _ ByVal X1 As Long, _ ByVal Y1 As Long, _ ByVal X2 As Long, _ ByVal Y2 As Long) As Boolean On Error Resume Next Dim ScreenHDC As Long ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Set the background and foreground colors for the screen DC SetColors ScreenHDC ' Draw the chord If DRAW_HalfCircle(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, X1, Y1, X2, Y2) <> 0 Then DrawHalfCircle = True Else ErrorHandler App.EXEName & ".cScreen.DrawHalfCircle(DRAW_HalfCircle)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Free the temp DC ReleaseDC ScreenHWND, ScreenHDC ' Record the draw item for refresh ability If RefreshingDisplay = False And s_EnableRefresh = True Then DHalfCircleInfoCount = DHalfCircleInfoCount + 1 ReDim Preserve DHalfCircleInfo(DHalfCircleInfoCount) As D_HalfCircleInfo DHalfCircleInfo(DHalfCircleInfoCount).dhTheBottom = TheBottom DHalfCircleInfo(DHalfCircleInfoCount).dhTheLeft = TheLeft DHalfCircleInfo(DHalfCircleInfoCount).dhTheRight = TheRight DHalfCircleInfo(DHalfCircleInfoCount).dhTheTop = TheTop DHalfCircleInfo(DHalfCircleInfoCount).dhX1 = X1 DHalfCircleInfo(DHalfCircleInfoCount).dhX2 = X2 DHalfCircleInfo(DHalfCircleInfoCount).dhY1 = Y1 DHalfCircleInfo(DHalfCircleInfoCount).dhY2 = Y2 DHalfCircleInfo(DHalfCircleInfoCount).dhBckClr_Scr = s_BackColor_Scr DHalfCircleInfo(DHalfCircleInfoCount).dhBckClr_Txt = s_BackColor_Txt DHalfCircleInfo(DHalfCircleInfoCount).dhFreClr_Scr = s_ForeColor_Scr DHalfCircleInfo(DHalfCircleInfoCount).dhFreClr_Txt = s_ForeColor_Txt End If DoEvents End Function ' Draws a line from the specified start point up to, but not including, the specified end point Public Function DrawLine(ByVal StartPointX As Long, _ ByVal StartPointY As Long, _ ByVal EndPointX As Long, _ ByVal EndPointY As Long) As Boolean On Error Resume Next Dim ScreenHDC As Long Dim CurX As Long Dim CurY As Long ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Set the start point If Me.GetCurrentXY(ScreenHDC, CurX, CurY) = False Then Exit Function Else If CurX <> StartPointX And CurY <> StartPointY Then If Me.SetCurrentXY(ScreenHDC, StartPointX, StartPointY) = False Then Exit Function End If End If End If ' Set the background and foreground colors for the screen DC SetColors ScreenHDC ' Draw the line If DRAW_Line(ScreenHDC, EndPointX, EndPointY) <> 0 Then DrawLine = True Else ErrorHandler App.EXEName & ".cScreen.DrawLine(DRAW_Line)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Free the temp DC ReleaseDC ScreenHWND, ScreenHDC ' Record the draw item for refresh ability If RefreshingDisplay = False And s_EnableRefresh = True Then DLineCount = DLineCount + 1 ReDim Preserve DLine(DLineCount) As D_Line DLine(DLineCount).dnEndPointX = EndPointX DLine(DLineCount).dnEndPointY = EndPointY DLine(DLineCount).dnStartPointX = StartPointX DLine(DLineCount).dnStartPointY = StartPointY DLine(DLineCount).dnBckClr_Scr = s_BackColor_Scr DLine(DLineCount).dnBckClr_Txt = s_BackColor_Txt DLine(DLineCount).dnFreClr_Scr = s_ForeColor_Scr DLine(DLineCount).dnFreClr_Txt = s_ForeColor_Txt End If DoEvents End Function ' Takes the specified file and draws it to the screen '-------------------------------------------------------------------------------------------- ' * IMPORTANT : '-------------------------------------------------------------------------------------------- ' - If the "EnableRefresh" property is set to TRUE and the "PicturePath" property is used to ' pass the picture to draw, the path to the picture is used to refresh the picture. If ' the picture file is deleted, the "Refresh" method will fail to redraw it. ' - If the "EnableRefresh" property is set to TRUE and the "PictureVariable" property is used ' to pass the picture to draw, a copy of the passed picture variable stored and is later ' used to refresh the picture. This could take up a lot of memory if several LARGE ' pictures are passed to this function this way. ' - If the "EnableRefresh" property is set to TRUE and the "PictureHandle" property is used ' to pass the picture to draw, a OLE StdPicture object is created from it and stored and is ' later used to refresh the picture. This could take up a lot of memory if several LARGE ' pictures are passed to this function this way. '-------------------------------------------------------------------------------------------- Public Function DrawPicture(ByVal X As Long, _ ByVal Y As Long, _ Optional ByVal PicturePath As String, _ Optional ByVal PictureVariable As StdPicture, _ Optional ByVal PictureHandle As Long, _ Optional ByVal OutputWidth As Long, _ Optional ByVal OutputHeight As Long, _ Optional ByVal Stretch As Boolean = False) As Boolean On Error Resume Next Dim ScreenHDC As Long Dim TempDC As Long Dim TempPic As StdPicture Dim hPicture As Long Dim ReturnValue As Long Dim UsePath As Boolean Dim UseVariable As Boolean Dim UseHandle As Boolean ' Make sure there is a valid picture specified to load If (PicturePath = "") And (PictureHandle = 0) And (PictureVariable Is Nothing) Then ErrorHandler App.EXEName & ".cScreen.DrawPicture", -1, "No picture specified to draw." Exit Function End If '---------------------- ' Check if the specified picture is valid If PicturePath <> "" Then If Dir(PicturePath) = "" Then ErrorHandler App.EXEName & ".cScreen.DrawPicture", -1, "Specified picture could not be found." Exit Function Else UsePath = True End If ' Check if the specified picture variable is valid ElseIf Not PictureVariable Is Nothing Then If PictureVariable.Handle = 0 Then ErrorHandler App.EXEName & ".cScreen.DrawPicture", -1, "Invalid picture variable specified." Exit Function Else UseVariable = True End If ' The picture handle at this point should be the only thing left and it is assumed that it is valid Else UseHandle = True End If '---------------------- ' Get handle from file picture If UsePath = True Then Set TempPic = LoadPicture(PicturePath) If (TempPic Is Nothing) Or Err Then ErrorHandler App.EXEName & ".cScreen.DrawPicture(LoadPicture)", Err.Number, Err.Description Exit Function Else hPicture = TempPic.Handle End If ' Get picture from handle ElseIf UseHandle = True Then Set TempPic = PictureFromHandle(PictureHandle) If TempPic Is Nothing Then Exit Function Else hPicture = TempPic.Handle End If ' Get handle from picture variable ElseIf UseVariable = True Then hPicture = PictureVariable.Handle End If '---------------------- ' If an output height/width is not specified, use the picture's dimentions If OutputWidth = 0 Then If UseVariable = True Then OutputWidth = PictureVariable.Width / s_TwipsX Else OutputWidth = TempPic.Width / s_TwipsX End If End If If OutputHeight = 0 Then If UseVariable = True Then OutputHeight = PictureVariable.Height / s_TwipsY Else OutputHeight = TempPic.Height / s_TwipsY End If End If '---------------------- ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Create a memory DC to work from TempDC = CreateCompatibleDC(ScreenHDC) If TempDC <> 0 Then SelectObject TempDC, hPicture If Stretch = True Then If DRAW_PictureStretch(ScreenHDC, X, Y, OutputWidth, OutputHeight, TempDC, 0, 0, TempPic.Width / s_TwipsX, TempPic.Height / s_TwipsY, SRCCOPY) = 0 Then ErrorHandler App.EXEName & ".cScreen.DrawPicture(DRAW_PictureStretch)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Else DrawPicture = True End If Else If DRAW_Picture(ScreenHDC, X, Y, OutputWidth, OutputHeight, TempDC, 0, 0, SRCCOPY) = 0 Then ErrorHandler App.EXEName & ".cScreen.DrawPicture(DRAW_Picture)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Else DrawPicture = True End If End If Else ErrorHandler App.EXEName & ".cScreen.DrawPicture(CreateCompatibleDC)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Clean up the memory used DeleteDC TempDC ReleaseDC ScreenHWND, ScreenHDC ' Record the draw item for refresh ability If RefreshingDisplay = False And s_EnableRefresh = True Then DPictureCount = DPictureCount + 1 ReDim Preserve DPicture(DPictureCount) As D_Picture If UseHandle = True Then DPicture(DPictureCount).dpPictureHandle = 0 DPicture(DPictureCount).dpPicturePath = "" Set DPicture(DPictureCount).dpPictureVariable = TempPic ElseIf UsePath = True Then DPicture(DPictureCount).dpPictureHandle = 0 DPicture(DPictureCount).dpPicturePath = PicturePath Set DPicture(DPictureCount).dpPictureVariable = Nothing ElseIf UseVariable = True Then DPicture(DPictureCount).dpPictureHandle = 0 DPicture(DPictureCount).dpPicturePath = "" Set DPicture(DPictureCount).dpPictureVariable = PictureVariable End If DPicture(DPictureCount).dpOutputHeight = OutputHeight DPicture(DPictureCount).dpOutputWidth = OutputWidth DPicture(DPictureCount).dpStretch = Stretch DPicture(DPictureCount).dpX = X DPicture(DPictureCount).dpY = Y DPicture(DPictureCount).dpBckClr_Scr = s_BackColor_Scr DPicture(DPictureCount).dpBckClr_Txt = s_BackColor_Txt DPicture(DPictureCount).dpFreClr_Scr = s_ForeColor_Scr DPicture(DPictureCount).dpFreClr_Txt = s_ForeColor_Txt End If ' Release temporary picture Set TempPic = Nothing DoEvents End Function ' Draws a pie-shaped wedge bounded by the intersection of an ellipse and two radials. The pie is outlined ' by using the current pen and filled by using the current brush. Public Function DrawPie(ByVal TheLeft As Long, _ ByVal TheTop As Long, _ ByVal TheRight As Long, _ ByVal TheBottom As Long, _ ByVal Percent As Long, _ Optional ByVal UseCustom As Boolean = False, _ Optional ByVal CustomX1 As Long, _ Optional ByVal CustomY1 As Long, _ Optional ByVal CustomX2 As Long, _ Optional ByVal CustomY2 As Long) As Boolean On Error Resume Next Dim ReturnValue As Long Dim X1 As Long Dim Y1 As Long Dim X2 As Long Dim Y2 As Long Dim MidTopX As Long Dim MidTopY As Long Dim MidRightX As Long Dim MidRightY As Long Dim MidBottomX As Long Dim MidBottomY As Long Dim MidLeftX As Long Dim MidLeftY As Long Dim Xd0 As Long Dim Yd0 As Long Dim Xd45 As Long Dim Yd45 As Long Dim Xd90 As Long Dim Yd90 As Long Dim Xd135 As Long Dim Yd135 As Long Dim Xd180 As Long Dim Yd180 As Long Dim Xd225 As Long Dim Yd225 As Long Dim Xd270 As Long Dim Yd270 As Long Dim Xd315 As Long Dim Yd315 As Long Dim Xd360 As Long Dim Yd360 As Long Dim OneXUnit As Long Dim OneYUnit As Long Dim ScreenHDC As Long ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Set the background and foreground colors for the screen DC SetColors ScreenHDC ' Make sure the percent specified is valid If Percent < 0 Then Percent = 0 ElseIf Percent > 360 Then Percent = 360 End If ' Draw the rectangle If UseCustom = True Then ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, CustomX1, CustomY1, CustomX2, CustomY2) Else GoSub GetDegrees Select Case Percent Case 0 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd0, Yd0) Case 45 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd45, Yd45) Case 90 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd90, Yd90) Case 135 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd135, Yd135) Case 180 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd180, Yd180) Case 225 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd225, Yd225) Case 270 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd270, Yd270) Case 315 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd315, Yd315) Case 360 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd360 - 1, Yd360) Case 1 To 44 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd0 + (Percent * OneXUnit), Yd0) Case 46 To 89 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd45, Yd45 + ((Percent - 45) * OneYUnit)) Case 91 To 134 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd90, Yd90 + ((Percent - 90) * OneYUnit)) Case 136 To 179 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd135 - ((Percent - 135) * OneXUnit), Yd135) Case 181 To 224 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd180 - ((Percent - 180) * OneXUnit), Yd180) Case 226 To 269 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd225, Yd225 - ((Percent - 225) * OneYUnit)) Case 271 To 314 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd270, Yd270 - ((Percent - 270) * OneYUnit)) Case 316 To 359 ReturnValue = DRAW_Pie(ScreenHDC, TheLeft, TheTop, TheRight, TheBottom, MidTopX, MidTopY, Xd315 + ((Percent - 315) * OneXUnit), Yd315) End Select End If ' Check the return value If ReturnValue <> 0 Then DrawPie = True Else ErrorHandler App.EXEName & ".cScreen.DrawPie(DRAW_Pie)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Free the temp DC ReleaseDC ScreenHWND, ScreenHDC ' Record the draw item for refresh ability If RefreshingDisplay = False And s_EnableRefresh = True Then DPieCount = DPieCount + 1 ReDim Preserve DPie(DPieCount) As D_Pie DPie(DPieCount).diCustomX1 = CustomX1 DPie(DPieCount).diCustomX2 = CustomX2 DPie(DPieCount).diCustomY1 = CustomY1 DPie(DPieCount).diCustomY2 = CustomY2 DPie(DPieCount).diPercent = Percent DPie(DPieCount).diTheBottom = TheBottom DPie(DPieCount).diTheLeft = TheLeft DPie(DPieCount).diTheRight = TheRight DPie(DPieCount).diTheTop = TheTop DPie(DPieCount).diUseCustom = UseCustom DPie(DPieCount).diBckClr_Scr = s_BackColor_Scr DPie(DPieCount).diBckClr_Txt = s_BackColor_Txt DPie(DPieCount).diFreClr_Scr = s_ForeColor_Scr DPie(DPieCount).diFreClr_Txt = s_ForeColor_Txt End If DoEvents Exit Function GetDegrees: X1 = TheLeft Y1 = TheTop X2 = TheRight Y2 = TheBottom MidTopX = ((X2 - X1) / 2) + X1 MidTopY = Y1 MidBottomX = MidTopX MidBottomY = Y2 MidLeftX = X1 MidLeftY = ((Y2 - Y1) / 2) + Y1 MidRightX = X2 MidRightY = MidLeftY OneXUnit = ((X2 - X1) + X1) / 90 OneYUnit = ((Y2 - Y1) + Y1) / 90 Xd0 = MidTopX Yd0 = MidTopY Xd45 = X2 Yd45 = Y1 Xd90 = MidRightX Yd90 = MidRightY Xd135 = X2 Yd135 = Y2 Xd180 = MidBottomX Yd180 = MidBottomY Xd225 = X1 Yd225 = Y2 Xd270 = MidLeftX Yd270 = MidLeftY Xd315 = X1 Yd315 = Y1 Xd360 = MidTopX Yd360 = MidTopY Return End Function ' Draws a polygon consisting of two or more vertices connected by straight lines. The polygon is outlined ' by using the current pen and filled by using the current brush and polygon fill mode. Public Function DrawPolygon(ByRef PointX_Array() As Long, _ ByRef PointY_Array() As Long, _ ByVal POINT_Count As Long) As Boolean On Error Resume Next Dim MyCounter As Long Dim POINTArray() As POINT_LNG Dim ScreenHDC As Long ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Set the background and foreground colors for the screen DC SetColors ScreenHDC ' Make sure parameters are valid If POINT_Count = 0 Then ErrorHandler App.EXEName & ".cScreen.DrawPolygon", -1, "Invalid POINT Count Specified" Exit Function End If ' Assign the X and Y point array values to the POINT array ReDim POINTArray(POINT_Count) As POINT_LNG For MyCounter = 0 To POINT_Count - 1 POINTArray(MyCounter).X = PointX_Array(MyCounter) POINTArray(MyCounter).Y = PointY_Array(MyCounter) Next ' Draw the Polygon If DRAW_Polygon(ScreenHDC, POINTArray(0), POINT_Count) <> 0 Then DrawPolygon = True Else ErrorHandler App.EXEName & ".cScreen.DrawPolygon(DRAW_Polygon)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Free the temp DC ReleaseDC ScreenHWND, ScreenHDC ' Record the draw item for refresh ability If RefreshingDisplay = False And s_EnableRefresh = True Then DPolygonCount = DPolygonCount + 1 ReDim Preserve DPolygon(DPolygonCount) As D_Polygon DPolygon(DPolygonCount).dgPOINT_Count = POINT_Count DPolygon(DPolygonCount).dgPointX_Array = PointX_Array DPolygon(DPolygonCount).dgPointY_Array = PointY_Array DPolygon(DPolygonCount).dgBckClr_Scr = s_BackColor_Scr DPolygon(DPolygonCount).dgBckClr_Txt = s_BackColor_Txt DPolygon(DPolygonCount).dgFreClr_Scr = s_ForeColor_Scr DPolygon(DPolygonCount).dgFreClr_Txt = s_ForeColor_Txt End If DoEvents End Function ' Draws a series of line segments by connecting the points in the specified array. Public Function DrawPolyline(ByVal StartPointX As Long, _ ByVal StartPointY As Long, _ ByRef PointX_Array() As Long, _ ByRef PointY_Array() As Long, _ ByVal POINT_Count As Long) As Boolean On Error Resume Next Dim MyCounter As Long Dim POINTArray() As POINT_LNG Dim ScreenHDC As Long ' Check the parameters If POINT_Count = 0 Then ErrorHandler App.EXEName & ".cScreen.DrawPolyline", -1, "Invalid POINT Count Specified" Exit Function End If ' Assign the X and Y point array values to the POINT array ReDim POINTArray(POINT_Count) As POINT_LNG For MyCounter = 0 To POINT_Count - 1 POINTArray(MyCounter).X = PointX_Array(MyCounter) POINTArray(MyCounter).Y = PointY_Array(MyCounter) Next ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Set the background and foreground colors for the screen DC SetColors ScreenHDC ' Set the start point If DRAW_MoveCurrentXY(ScreenHDC, StartPointX, StartPointY, 0) = 0 Then ErrorHandler App.EXEName & ".cScreen.DrawPolyline(DRAW_MoveCurrentXY)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Exit Function End If ' Draw the polyline If DRAW_Polyline(ScreenHDC, POINTArray(0), POINT_Count) <> 0 Then DrawPolyline = True Else ErrorHandler App.EXEName & ".cScreen.DrawPolyline(DRAW_Polyline)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Free the temp DC ReleaseDC ScreenHWND, ScreenHDC ' Record the draw item for refresh ability If RefreshingDisplay = False And s_EnableRefresh = True Then DPolylineCount = DPolylineCount + 1 ReDim Preserve DPolyline(DPolylineCount) As D_Polyline DPolyline(DPolylineCount).dlPOINT_Count = POINT_Count DPolyline(DPolylineCount).dlPointX_Array = PointX_Array DPolyline(DPolylineCount).dlPointY_Array = PointY_Array DPolyline(DPolylineCount).dlStartPointX = StartPointX DPolyline(DPolylineCount).dlStartPointY = StartPointY DPolyline(DPolylineCount).dlBckClr_Scr = s_BackColor_Scr DPolyline(DPolylineCount).dlBckClr_Txt = s_BackColor_Txt DPolyline(DPolylineCount).dlFreClr_Scr = s_ForeColor_Scr DPolyline(DPolylineCount).dlFreClr_Txt = s_ForeColor_Txt End If DoEvents End Function ' The FillRect function fills a rectangle by using the specified brush. This function includes the ' left and top borders, but excludes the right and bottom borders of the rectangle. '---------- ' The FrameRect function draws a border around the specified rectangle by using the specified brush. ' The width and height of the border are always one logical unit. Public Function DrawRectangle(ByVal TheLeft As Long, _ ByVal TheTop As Long, _ ByVal TheRight As Long, _ ByVal TheBottom As Long, _ Optional ByVal Filled As Boolean = True, _ Optional ByVal Border As Boolean = True) As Boolean On Error Resume Next Dim rTemp As RECT Dim ScreenHDC As Long Dim hBRUSH As Long ' If there's nothing in the middle and nothing on the outside, there's nothing... so exit If Filled = False And Border = False Then ErrorHandler App.EXEName & ".cScreen.DrawRectangle", -1, "Invalid Parameters Specified" Exit Function End If ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Set the background and foreground colors for the screen DC SetColors ScreenHDC ' Setup the location of the rectangle With rTemp .Left = TheLeft .Top = TheTop .Right = TheRight .Bottom = TheBottom End With ' If specified to draw the rectangle filled, do so If Filled = True Then ' Get a brush to use to draw the INSIDE rectangle If GetBrush(s_BackColor_Scr, hBRUSH) = False Then GoTo CleanUp End If ' Draw the inside of the rectangle If DRAW_RectangleFilled(ScreenHDC, rTemp, hBRUSH) <> 0 Then DrawRectangle = True Else ErrorHandler App.EXEName & ".cScreen.DrawRectangle(DRAW_RectangleFilled)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Delete the brush used DeleteObject hBRUSH hBRUSH = 0 End If ' If specified to draw a border around it, do so here If Border = True Then ' Get a brush to use to draw the INSIDE rectangle If GetBrush(s_ForeColor_Scr, hBRUSH) = False Then GoTo CleanUp End If ' Draw the boarder to the rectangle If DRAW_RectangleOutline(ScreenHDC, rTemp, hBRUSH) <> 0 Then DrawRectangle = True Else ErrorHandler App.EXEName & ".cScreen.DrawRectangle(DRAW_RectangleOutline)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Delete the brush used DeleteObject hBRUSH hBRUSH = 0 End If ' Record the draw item for refresh ability If RefreshingDisplay = False And s_EnableRefresh = True Then DRectangleCount = DRectangleCount + 1 ReDim Preserve DRectangle(DRectangleCount) As D_Rectangle DRectangle(DRectangleCount).drBorder = Border DRectangle(DRectangleCount).drFilled = Filled DRectangle(DRectangleCount).drTheBottom = TheBottom DRectangle(DRectangleCount).drTheLeft = TheLeft DRectangle(DRectangleCount).drTheRight = TheRight DRectangle(DRectangleCount).drTheTop = TheTop DRectangle(DRectangleCount).drBckClr_Scr = s_BackColor_Scr DRectangle(DRectangleCount).drBckClr_Txt = s_BackColor_Txt DRectangle(DRectangleCount).drFreClr_Scr = s_ForeColor_Scr DRectangle(DRectangleCount).drFreClr_Txt = s_ForeColor_Txt End If CleanUp: ' Free the temp DC ReleaseDC ScreenHWND, ScreenHDC DoEvents End Function ' Draws formatted text in the specified rectangle. It formats the text according to the specified ' method (expanding tabs, justifying characters, breaking lines, and so forth). '--------------------- ' * NOTE - You can change the font that is to be drawn using the "Font" property Public Function drawText(ByVal Text As String, _ ByVal TheLeft As Long, _ ByVal TheTop As Long, _ Optional ByVal WordWrap As Boolean = True) As Boolean On Error Resume Next Dim ReturnValue As Long Dim rTemp As RECT Dim TextFormats As Long Dim ScreenHDC As Long Dim hFont As Long ' Validate text to be drawn If Text = "" Then drawText = True Exit Function ElseIf Right(Text, 1) <> Chr(0) Then Text = Text & Chr(0) End If ' Get a handle to the current Device Context of the screen ScreenHDC = Me.hDC ' Set the background and foreground colors for the screen DC SetColors ScreenHDC ' Put the current font into the screen for display If GetFont(ScreenHDC, s_Font, hFont) = True Then SetDisplayFont ScreenHDC, hFont End If ' Get the text formating to use If WordWrap = True Then TextFormats = DT_WORDBREAK Or DT_LEFT Or DT_TOP Or DT_EXPANDTABS Else TextFormats = DT_SINGLELINE Or DT_LEFT Or DT_TOP Or DT_EXPANDTABS End If ' Create a rectangle to use when calling the DrawText function With rTemp .Left = TheLeft .Top = TheTop .Right = 100 ' This doesn't matter since it autosizes the text .Bottom = DRAW_DrawText(ScreenHDC, Text, -1, rTemp, DT_CALCRECT) If .Bottom = 0 Then ErrorHandler App.EXEName & ".cScreen.DrawText(DRAW_DrawText)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Exit Function End If .Bottom = .Bottom + .Top End With ' Draw the text ReturnValue = DRAW_DrawText(ScreenHDC, Text, -1, rTemp, TextFormats) If ReturnValue <> 0 Then drawText = True Else ErrorHandler App.EXEName & ".cScreen.DrawText(DRAW_DrawText)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If ' Free the temp DC ReleaseDC ScreenHWND, ScreenHDC DeleteObject hFont ' Record the draw item for refresh ability If RefreshingDisplay = False And s_EnableRefresh = True Then DTextCount = DTextCount + 1 ReDim Preserve DText(DTextCount) As D_Text DText(DTextCount).dtText = Text DText(DTextCount).dtTheLeft = TheLeft DText(DTextCount).dtTheTop = TheTop DText(DTextCount).dtWordWrap = WordWrap DText(DTextCount).dtBckClr_Scr = s_BackColor_Scr DText(DTextCount).dtBckClr_Txt = s_BackColor_Txt DText(DTextCount).dtFreClr_Scr = s_ForeColor_Scr DText(DTextCount).dtFreClr_Txt = s_ForeColor_Txt End If DoEvents End Function ' Get the current X,Y coordinates on the screen Public Function GetCurrentXY(ByVal hScreenDC As Long, ByRef ReturnX As Long, ByRef ReturnY As Long) As Boolean Dim OldXY As POINT_LNG ' Make sure the parameters are valid If hScreenDC = 0 Then ErrorHandler App.EXEName & ".cScreen.SetDisplayFont", -1, "Invalid DC Specified" Exit Function End If ' Clear the passed variables first ReturnX = 0 ReturnY = 0 ' Get the current X,Y position by changing it, getting the return value that represents ' the old X,Y then resetting it to what it was before If DRAW_MoveCurrentXY(hScreenDC, 0, 0, OldXY) <> 0 Then ReturnX = OldXY.X ReturnY = OldXY.Y DRAW_MoveCurrentXY hScreenDC, OldXY.X, OldXY.Y, 0 GetCurrentXY = True Else ErrorHandler App.EXEName & ".cScreen.GetCurrentXY(DRAW_MoveCurrentXY)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If End Function ' * NOTE - In order for this function to redraw all objects on the screen correctly, ' you must make sure that you draw the objects to the screen in the order ' this function redraws them: ' Arc, Ellipse, Half Circle, Line, Picture, Pie, Polygon, Polyline, Rectangle, Text Public Function Refresh() As Boolean On Error Resume Next Dim MyCounter As Long Dim ScreenHDC As Long Dim PrevBckClr_Scr As Long Dim PrevBckClr_Txt As Long Dim PrevFreClr_Scr As Long Dim PrevFreClr_Txt As Long ' Store the current colors in order to return them to their original after ' this function is finished PrevBckClr_Scr = s_BackColor_Scr PrevBckClr_Txt = s_BackColor_Txt PrevFreClr_Scr = s_ForeColor_Scr PrevFreClr_Txt = s_ForeColor_Txt ' This tells the draw functions NOT to record the current draw ' because it's a repeat draw instead of an original draw RefreshingDisplay = True ' Redraw All Arc's If DArcInfoCount > 0 Then For MyCounter = 1 To DArcInfoCount ' Set the correct colors so the object will be correctly redrawn s_BackColor_Scr = DArcInfo(MyCounter).daBckClr_Scr s_BackColor_Txt = DArcInfo(MyCounter).daBckClr_Txt s_ForeColor_Scr = DArcInfo(MyCounter).daFreClr_Scr s_ForeColor_Txt = DArcInfo(MyCounter).daFreClr_Txt ' Redraw the object If Me.DrawArc(DArcInfo(MyCounter).daCenterPointX, _ DArcInfo(MyCounter).daCenterPointY, _ DArcInfo(MyCounter).daRadius, _ DArcInfo(MyCounter).daStartPointX, _ DArcInfo(MyCounter).daStartPointY, _ DArcInfo(MyCounter).daStartAngle, _ DArcInfo(MyCounter).daSweepAngle) = False Then GoTo Finished End If Next End If ' Redraw All Ellipse's If DEllipseInfoCount > 0 Then For MyCounter = 1 To DEllipseInfoCount ' Set the correct colors so the object will be correctly redrawn s_BackColor_Scr = DEllipseInfo(MyCounter).deBckClr_Scr s_BackColor_Txt = DEllipseInfo(MyCounter).deBckClr_Txt s_ForeColor_Scr = DEllipseInfo(MyCounter).deFreClr_Scr s_ForeColor_Txt = DEllipseInfo(MyCounter).deFreClr_Txt ' Redraw the object If Me.DrawEllipse(DEllipseInfo(MyCounter).deTheLeft, _ DEllipseInfo(MyCounter).deTheTop, _ DEllipseInfo(MyCounter).deTheRight, _ DEllipseInfo(MyCounter).deTheBottom) = False Then GoTo Finished End If Next End If ' Redraw All Half Circle's If DHalfCircleInfoCount > 0 Then For MyCounter = 1 To DHalfCircleInfoCount ' Set the correct colors so the object will be correctly redrawn s_BackColor_Scr = DHalfCircleInfo(MyCounter).dhBckClr_Scr s_BackColor_Txt = DHalfCircleInfo(MyCounter).dhBckClr_Txt s_ForeColor_Scr = DHalfCircleInfo(MyCounter).dhFreClr_Scr s_ForeColor_Txt = DHalfCircleInfo(MyCounter).dhFreClr_Txt ' Redraw the object If Me.DrawHalfCircle(DHalfCircleInfo(MyCounter).dhTheLeft, _ DHalfCircleInfo(MyCounter).dhTheTop, _ DHalfCircleInfo(MyCounter).dhTheRight, _ DHalfCircleInfo(MyCounter).dhTheBottom, _ DHalfCircleInfo(MyCounter).dhX1, _ DHalfCircleInfo(MyCounter).dhY1, _ DHalfCircleInfo(MyCounter).dhX2, _ DHalfCircleInfo(MyCounter).dhY2) = False Then GoTo Finished End If Next End If ' Redraw All Line's If DLineCount > 0 Then For MyCounter = 1 To DLineCount ' Set the correct colors so the object will be correctly redrawn s_BackColor_Scr = DLine(MyCounter).dnBckClr_Scr s_BackColor_Txt = DLine(MyCounter).dnBckClr_Txt s_ForeColor_Scr = DLine(MyCounter).dnFreClr_Scr s_ForeColor_Txt = DLine(MyCounter).dnFreClr_Txt ' Redraw the object If Me.DrawLine(DLine(MyCounter).dnStartPointX, _ DLine(MyCounter).dnStartPointY, _ DLine(MyCounter).dnEndPointX, _ DLine(MyCounter).dnEndPointY) = False Then GoTo Finished End If Next End If ' Redraw All Pictures's If DPictureCount > 0 Then For MyCounter = 1 To DPictureCount ' Set the correct colors so the object will be correctly redrawn s_BackColor_Scr = DPicture(MyCounter).dpBckClr_Scr s_BackColor_Txt = DPicture(MyCounter).dpBckClr_Txt s_ForeColor_Scr = DPicture(MyCounter).dpFreClr_Scr s_ForeColor_Txt = DPicture(MyCounter).dpFreClr_Txt ' Redraw the object If Me.DrawPicture(DPicture(MyCounter).dpX, _ DPicture(MyCounter).dpY, _ DPicture(MyCounter).dpPicturePath, _ DPicture(MyCounter).dpPictureVariable, _ DPicture(MyCounter).dpPictureHandle, _ DPicture(MyCounter).dpOutputWidth, _ DPicture(MyCounter).dpOutputHeight, _ DPicture(MyCounter).dpStretch) = False Then GoTo Finished End If Next End If ' Redraw All Pie's If DPieCount > 0 Then For MyCounter = 1 To DPieCount ' Set the correct colors so the object will be correctly redrawn s_BackColor_Scr = DPie(MyCounter).diBckClr_Scr s_BackColor_Txt = DPie(MyCounter).diBckClr_Txt s_ForeColor_Scr = DPie(MyCounter).diFreClr_Scr s_ForeColor_Txt = DPie(MyCounter).diFreClr_Txt ' Redraw the object If Me.DrawPie(DPie(MyCounter).diTheLeft, _ DPie(MyCounter).diTheTop, _ DPie(MyCounter).diTheRight, _ DPie(MyCounter).diTheBottom, _ DPie(MyCounter).diPercent, _ DPie(MyCounter).diUseCustom, _ DPie(MyCounter).diCustomX1, _ DPie(MyCounter).diCustomY1, _ DPie(MyCounter).diCustomX2, _ DPie(MyCounter).diCustomY2) = False Then GoTo Finished End If Next End If ' Redraw All Polygon's If DPolygonCount > 0 Then For MyCounter = 1 To DPolygonCount ' Set the correct colors so the object will be correctly redrawn s_BackColor_Scr = DPolygon(MyCounter).dgBckClr_Scr s_BackColor_Txt = DPolygon(MyCounter).dgBckClr_Txt s_ForeColor_Scr = DPolygon(MyCounter).dgFreClr_Scr s_ForeColor_Txt = DPolygon(MyCounter).dgFreClr_Txt ' Redraw the object If Me.DrawPolygon(DPolygon(MyCounter).dgPointX_Array, _ DPolygon(MyCounter).dgPointY_Array, _ DPolygon(MyCounter).dgPOINT_Count) = False Then GoTo Finished End If Next End If ' Redraw All Polyline's If DPolylineCount > 0 Then For MyCounter = 1 To DPolylineCount ' Set the correct colors so the object will be correctly redrawn s_BackColor_Scr = DPolyline(MyCounter).dlBckClr_Scr s_BackColor_Txt = DPolyline(MyCounter).dlBckClr_Txt s_ForeColor_Scr = DPolyline(MyCounter).dlFreClr_Scr s_ForeColor_Txt = DPolyline(MyCounter).dlFreClr_Txt ' Redraw the object If Me.DrawPolyline(DPolyline(MyCounter).dlStartPointX, _ DPolyline(MyCounter).dlStartPointY, _ DPolyline(MyCounter).dlPointX_Array, _ DPolyline(MyCounter).dlPointY_Array, _ DPolyline(MyCounter).dlPOINT_Count) = False Then GoTo Finished End If Next End If ' Redraw All Rectangle's If DRectangleCount > 0 Then For MyCounter = 1 To DRectangleCount ' Set the correct colors so the object will be correctly redrawn s_BackColor_Scr = DRectangle(MyCounter).drBckClr_Scr s_BackColor_Txt = DRectangle(MyCounter).drBckClr_Txt s_ForeColor_Scr = DRectangle(MyCounter).drFreClr_Scr s_ForeColor_Txt = DRectangle(MyCounter).drFreClr_Txt ' Redraw the object If Me.DrawRectangle(DRectangle(MyCounter).drTheLeft, _ DRectangle(MyCounter).drTheTop, _ DRectangle(MyCounter).drTheRight, _ DRectangle(MyCounter).drTheBottom, _ DRectangle(MyCounter).drFilled, _ DRectangle(MyCounter).drBorder) = False Then GoTo Finished End If Next End If ' Redraw All Text's If DTextCount > 0 Then For MyCounter = 1 To DTextCount ' Set the correct colors so the object will be correctly redrawn s_BackColor_Scr = DText(MyCounter).dtBckClr_Scr s_BackColor_Txt = DText(MyCounter).dtBckClr_Txt s_ForeColor_Scr = DText(MyCounter).dtFreClr_Scr s_ForeColor_Txt = DText(MyCounter).dtFreClr_Txt ' Redraw the object If Me.drawText(DText(MyCounter).dtText, _ DText(MyCounter).dtTheLeft, _ DText(MyCounter).dtTheTop, _ DText(MyCounter).dtWordWrap) = False Then GoTo Finished End If Next End If Finished: ' This tells draw functions to start recording draws again RefreshingDisplay = False ' Restore the previous colors s_BackColor_Scr = PrevBckClr_Scr s_BackColor_Txt = PrevBckClr_Txt s_ForeColor_Scr = PrevFreClr_Scr s_ForeColor_Txt = PrevFreClr_Txt End Function ' Resets the information about the display Public Function RefreshDisplayInfo(Optional ByVal hScreenDC As Long = 0) As Boolean Dim ScreenHDC As Long ' Get the handle of the display area of the screen ScreenHWND = GetDesktopWindow If ScreenHWND = 0 Then MsgBox "Could not get the handle to the screen (hWnd). This information is critical and this module can not function propertly without it.", vbOKOnly + vbCritical, " Could Not Get Screen hWnd" ErrorHandler App.EXEName & ".cScreen.RefreshDisplayInfo(WindowFromDC)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Exit Function End If ' Get the handle to the Device Context of the display area of the screen If hScreenDC = 0 Then ScreenHDC = Me.hDC Else ScreenHDC = hScreenDC End If If ScreenHDC = 0 Then MsgBox "Could not get the handle to the screen's Device Context (DC). This information is critical and this module can not function propertly without it.", vbOKOnly + vbCritical, " Could Not Get Screen hDC" ErrorHandler App.EXEName & ".cScreen.RefreshDisplayInfo(GetWindowDC)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Exit Function End If ' Get information on all available devices on the user's computer GetDevices ' Get the current display information GetDisplayInfo ScreenHDC ' Get the current fonts available GetFontInfo ScreenHDC ' Free the temp DC If hScreenDC = 0 Then ReleaseDC ScreenHWND, ScreenHDC End If RefreshDisplayInfo = True End Function ' Set the current X,Y coordinates on the screen Public Function SetCurrentXY(ByVal hScreenDC As Long, ByVal X As Long, ByVal Y As Long) As Boolean ' Make sure the parameters are valid If hScreenDC = 0 Then ErrorHandler App.EXEName & ".cScreen.SetDisplayFont", -1, "Invalid DC Specified" Exit Function End If ' Move the current X,Y to the specified location If DRAW_MoveCurrentXY(hScreenDC, X, Y, 0) <> 0 Then SetCurrentXY = True Else ErrorHandler App.EXEName & ".cScreen.SetCurrentXY(DRAW_MoveCurrentXY)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If End Function '================================================================================================== ' CLASS PROPERTIES '================================================================================================== ' Sets the background or fill color for objects drawn to the screenBitBlt Public Property Get BackColor_Scr() As Long BackColor_Scr = s_BackColor_Scr End Property Public Property Let BackColor_Scr(ByVal NewValue As Long) Dim TempColor As Long TempColor = TranslateColor(NewValue) If TempColor <> -1 Then s_BackColor_Scr = NewValue Else ErrorHandler App.EXEName & ".cScreen.Let_BackColor_Scr(TranslateColor)", -1, "Invalid Color Specified" End If End Property ' Sets the foreground or outline color for objects drawn to the screenBitBlt Public Property Get ForeColor_Scr() As Long ForeColor_Scr = s_ForeColor_Scr End Property Public Property Let ForeColor_Scr(ByVal NewValue As Long) Dim TempColor As Long TempColor = TranslateColor(NewValue) If TempColor <> -1 Then s_ForeColor_Scr = NewValue Else ErrorHandler App.EXEName & ".cScreen.Let_ForeColor_Scr(TranslateColor)", -1, "Invalid Color Specified" End If End Property ' Sets the background color for any text drawn to the screen Public Property Get BackColor_Txt() As Long BackColor_Txt = s_BackColor_Txt End Property Public Property Let BackColor_Txt(ByVal NewValue As Long) Dim TempColor As Long TempColor = TranslateColor(NewValue) If TempColor <> -1 Then s_BackColor_Txt = NewValue Else ErrorHandler App.EXEName & ".cScreen.Let_BackColor_Txt(TranslateColor)", -1, "Invalid Color Specified" End If End Property ' Sets the foreground or font color used to draw text to the screen Public Property Get ForeColor_Txt() As Long ForeColor_Txt = s_ForeColor_Txt End Property Public Property Let ForeColor_Txt(ByVal NewValue As Long) Dim TempColor As Long TempColor = TranslateColor(NewValue) If TempColor <> -1 Then s_ForeColor_Txt = NewValue Else ErrorHandler App.EXEName & ".cScreen.Let_ForeColor_Txt(TranslateColor)", -1, "Invalid Color Specified" End If End Property ' Returns a handle to the screen's Device Context (DC) ' ------------------------------------------------------------------------------------------- ' * IMPORTANT - The routine that calls this property needs to free the DC handle returned ' by calling the ReleaseDC API : ReleaseDC ScreenHWND, ' ------------------------------------------------------------------------------------------- Public Property Get hDC() As Long hDC = GetDC(0) If hDC = 0 Then ErrorHandler App.EXEName & ".cScreen.hDC(GetDC)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End Property ' Returns the handle to the screen's window Public Property Get hWnd() As Long hWnd = ScreenHWND End Property ' Sets the brush style to be used when drawing items to the screen Public Property Get BrushSyle() As BrushStyles BrushSyle = s_BrushStyle End Property Public Property Let BrushSyle(ByVal NewValue As BrushStyles) s_BrushStyle = NewValue End Property ' Sets the hatching style to be used when drawing items to the screen ' (This is only used when the "BrushSyle" property is set to BS_HATCHED) Public Property Get BrushHatch() As HatchStyles BrushHatch = s_BrushHatch End Property Public Property Let BrushHatch(ByVal NewValue As HatchStyles) s_BrushHatch = NewValue End Property ' Sets the style of pen to be used when drawing lines or borders to the screen Public Property Get PenStyle() As PenStyles PenStyle = s_PenStyle End Property Public Property Let PenStyle(ByVal NewValue As PenStyles) s_PenStyle = NewValue End Property ' Sets the thickness of pen that is used to draw lines and borders to the screen Public Property Get PenWidth() As Long PenWidth = s_PenWidth End Property Public Property Let PenWidth(ByVal NewValue As Long) s_PenWidth = NewValue End Property ' Returns how many Twips exist on the current screen per pixel (X Axis) Public Property Get TwipsPerPixelX() As Single TwipsPerPixelX = s_TwipsX End Property ' Returns how many Twips exist on the current screen per pixel (Y Axis) Public Property Get TwipsPerPixelY() As Single TwipsPerPixelY = s_TwipsY End Property ' Returns the current color depth of the screen Public Property Get BitsPerPixel() As ColorDepths Select Case s_BitsPerPixel Case 1, 2 ' Black And White BitsPerPixel = BPP_Monocrome Case 4 ' 4 bits for 16 colors BitsPerPixel = BPP_16_Colors Case 8 ' 8 bits for 256 colors BitsPerPixel = BPP_256_Colors Case 16 ' 16 bits for 65536 colors BitsPerPixel = BPP_65536_Colors Case 24 ' 24 bits for 24bit Color BitsPerPixel = BPP_24Bit_Color Case 32 ' 32 bits for True Color BitsPerPixel = BPP_True_Color Case Else BitsPerPixel = BPP_Unknown End Select End Property ' Returns the current height of the screen in pixels Public Property Get Height() As Single Height = s_Height End Property ' Returns the current width of the screen in pixels Public Property Get Width() As Single Width = s_Width End Property ' Returns the number of display devices exist on the current machine ' (Win98 & Win2000 Only) Public Property Get DisplayDevice_Count() As Long DisplayDevice_Count = s_DeviceCount End Property ' Returns the name of the specified display devices by index on the current machine ' (Win98 & Win2000 Only) Public Property Get DisplayDevice_Name(ByVal Index As Long) As Long DisplayDevice_Name = s_DeviceName(Index) End Property ' Returns the description of the specified display devices by index on the current machine ' (Win98 & Win2000 Only) Public Property Get DisplayDevice_Description(ByVal Index As Long) As Long DisplayDevice_Description = s_DeviceStr(Index) End Property ' Sets the thickness of pen that is used to draw lines and borders to the screen Public Property Get EnableRefresh() As Boolean EnableRefresh = s_EnableRefresh End Property Public Property Let EnableRefresh(ByVal NewValue As Boolean) s_EnableRefresh = NewValue End Property ' Set the font for the display screen Public Property Get Font() As Font Dim TempFont As StdFont Set TempFont = New StdFont TempFont.Name = s_Font.fontName TempFont.Size = s_Font.PointSize TempFont.Bold = s_Font.Bold TempFont.Italic = s_Font.Italic TempFont.Underline = s_Font.Underline TempFont.Strikethrough = s_Font.StrikeThru TempFont.Charset = 0 If s_Font.Bold = True Then TempFont.Weight = 700 Else TempFont.Weight = 400 End If Set Font = TempFont Set TempFont = Nothing End Property Public Property Set Font(ByVal NewValue As Font) s_Font.fontName = NewValue.Name s_Font.PointSize = NewValue.Size s_Font.Bold = NewValue.Bold s_Font.Italic = NewValue.Italic s_Font.Underline = NewValue.Underline s_Font.StrikeThru = NewValue.Strikethrough End Property ' Returns how many fonts are available for use with the screen Public Property Get FontsCount() As Long FontsCount = s_FontsCount End Property ' Returns the name of the specified font by index Public Property Get Fonts(ByVal Index As Long) As String Fonts = s_Fonts(Index) End Property ' Returns the path to the external Cursor file to load and use with the "MousePointer" property Public Property Get MouseIcon() As String MouseIcon = s_MouseIcon End Property Public Property Let MouseIcon(ByVal NewValue As String) On Error GoTo FileDoesntExist Dim FreeFileNum As Integer ' Make sure that the path passed is a valid path by trying to open it. ' If it opens without an error that means that the file exists FreeFileNum = FreeFile Open NewValue For Input As #FreeFileNum Close #FreeFileNum ' Make sure the file passed is an ICON, CURSOR, or ANIMATED CURSOR If UCase(Right(NewValue, 4)) <> ".ICO" And _ UCase(Right(NewValue, 4)) <> ".CUR" And _ UCase(Right(NewValue, 4)) <> ".ANI" Then MsgBox "Invalid mouse icon file. File must be an .ICO, .CUR, or .ANI file.", vbOKOnly + vbExclamation, " Invalid File Type" Exit Property End If s_MouseIcon = NewValue FileDoesntExist: End Property ' Returns the type of mouse pointer is assigned to the specified window ' ----------------- ' Windows 95/98 : The SetWindowLong function may fail if the window handle specified does not belong to the same process as the calling thread. ' Windows NT/2000 : The SetWindowLong function will ALWAYS fail if the window handle specified does not belong to the same process as the calling thread. Public Property Get MousePointer(ByVal WindowHandle As Long) As Cursors Dim CurrentCursor As Long Dim TestCursor As Long ' If no handle is specified, use the screen's handle If WindowHandle = 0 Then WindowHandle = ScreenHWND End If ' Get the current cursor CurrentCursor = GetClassLong(WindowHandle, GCL_HCURSOR) If CurrentCursor = 0 Then ErrorHandler App.EXEName & ".cScreen.MousePointer(GetClassLong)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Exit Property End If ' Test each type of cursor to see which one it is TestCursor = LoadCursor(0, IDC_APPSTARTING) If TestCursor = CurrentCursor Then MousePointer = IDC_APPSTARTING Exit Property End If TestCursor = LoadCursor(0, IDC_ARROW) If TestCursor = CurrentCursor Then MousePointer = IDC_ARROW Exit Property End If TestCursor = LoadCursor(0, IDC_CROSS) If TestCursor = CurrentCursor Then MousePointer = IDC_CROSS Exit Property End If TestCursor = LoadCursor(0, IDC_HELP) If TestCursor = CurrentCursor Then MousePointer = IDC_HELP Exit Property End If TestCursor = LoadCursor(0, IDC_IBEAM) If TestCursor = CurrentCursor Then MousePointer = IDC_IBEAM Exit Property End If TestCursor = LoadCursor(0, IDC_ICON) If TestCursor = CurrentCursor Then MousePointer = IDC_ICON Exit Property End If TestCursor = LoadCursor(0, IDC_NO) If TestCursor = CurrentCursor Then MousePointer = IDC_NO Exit Property End If TestCursor = LoadCursor(0, IDC_SIZE) If TestCursor = CurrentCursor Then MousePointer = IDC_SIZE Exit Property End If TestCursor = LoadCursor(0, IDC_SIZEALL) If TestCursor = CurrentCursor Then MousePointer = IDC_SIZEALL Exit Property End If TestCursor = LoadCursor(0, IDC_SIZENESW) If TestCursor = CurrentCursor Then MousePointer = IDC_SIZENESW Exit Property End If TestCursor = LoadCursor(0, IDC_SIZENS) If TestCursor = CurrentCursor Then MousePointer = IDC_SIZENS Exit Property End If TestCursor = LoadCursor(0, IDC_SIZENWSE) If TestCursor = CurrentCursor Then MousePointer = IDC_SIZENWSE Exit Property End If TestCursor = LoadCursor(0, IDC_SIZEWE) If TestCursor = CurrentCursor Then MousePointer = IDC_SIZEWE Exit Property End If TestCursor = LoadCursor(0, IDC_UPARROW) If TestCursor = CurrentCursor Then MousePointer = IDC_UPARROW Exit Property End If TestCursor = LoadCursor(0, IDC_WAIT) If TestCursor = CurrentCursor Then MousePointer = IDC_WAIT Exit Property End If MousePointer = IDC_CUSTOM End Property ' Sets the type of mouse pointer is assigned to the specified window ' ----------------- ' Windows 95/98 : The SetWindowLong function may fail if the window handle specified does not belong to the same process as the calling thread. ' Windows NT/2000 : The SetWindowLong function will ALWAYS fail if the window handle specified does not belong to the same process as the calling thread. Public Property Let MousePointer(ByVal WindowHandle As Long, ByVal NewValue As Cursors) On Error Resume Next Dim hCursor As Long Dim hNewCursor As Long Dim ReturnValue As Long Dim HiLoValue As Long Dim CursorValue As Integer ' If no handle is specified, use the screen's handle If WindowHandle = 0 Then WindowHandle = ScreenHWND End If ' If the specified cursor is CUSTOM, then load the one specified by the MouseIcon parameter If NewValue = IDC_CUSTOM Then If s_MouseIcon = "" Then Exit Property Else hCursor = LoadImageSTR(App.hInstance, s_MouseIcon, IMAGE_ICON, 0, 0, LR_LOADFROMFILE) If hCursor <> 0 Then If AttachThread(WindowHandle, True) = False Then Exit Property ReturnValue = SetClassLong(WindowHandle, GCL_HCURSOR, hCursor) If Err.LastDllError <> 0 Then ErrorHandler App.EXEName & ".cScreen.MousePointer(SetClassLong)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If If AttachThread(WindowHandle, False) = False Then Exit Property DestroyCursor hCursor Exit Property Else ErrorHandler App.EXEName & ".cScreen.MousePointer(LoadImageSTR)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If End If ' Load a system cursor Else hCursor = LoadCursor(0, NewValue) If hCursor <> 0 Then ReturnValue = SetClassLong(WindowHandle, GCL_HCURSOR, hCursor) If ReturnValue = 0 Then ErrorHandler App.EXEName & ".cScreen.MousePointer(SetClassLong)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If End If End If End Property ' This function returns a reference to the form that is currently active ' ------------------------------------------------------------------------------------------- ' NOTE : This property doesn't work in DEBUG mode because when debugging, ' this property see's VB's IDE as the active form in the process. ' ------------------------------------------------------------------------------------------- Public Property Get ActiveForm() As Form On Error Resume Next Dim ActForm As Long Dim Form As Form ' Get the active form in the process ActForm = GetActiveWindow ' Check if there is no form in the process that is currently active If ActForm = 0 Then Exit Property End If ' If there are no forms in the current project, exit If Forms.Count = 0 Then Exit Property End If ' Find the form that matches the active form For Each Form In Forms If Form.hWnd = ActForm Then Set ActiveForm = Form GoTo FreeMemory End If Next FreeMemory: Set Form = Nothing End Property ' This function returns a reference to the control that is currently active on ' the form that is currently active ' ------------------------------------------------------------------------------------------- ' NOTE : This property doesn't work in DEBUG mode because when debugging, ' this property see's VB's IDE as the active form in the process ' and the code window as the active control in that form. ' ------------------------------------------------------------------------------------------- Public Property Get ActiveControl() As Control On Error Resume Next Dim Form As Form Dim Control As Control Dim ActForm As Long Dim ActCtrl As Long Dim FoundIt As Boolean ' Get the handle of the active form and the active control in the current process ActForm = GetActiveWindow ActCtrl = GetFocus ' Check for zero return... which indicates no forms in the current process are active If ActForm = 0 Or ActCtrl = 0 Then Exit Property End If ' If there are no forms in the current project, exit If Forms.Count = 0 Then Exit Property End If ' Search the forms the the one matching "ActForm" For Each Form In Forms If Form.hWnd = ActForm Then FoundIt = True Exit For End If Next ' Check if the right form was found If FoundIt = True Then ' If there are no controls on the active form, exit If Form.Controls.Count = 0 Then GoTo FreeMemory End If ' This way is a shortcut to searching for the right control Set ActiveControl = Form.ActiveControl GoTo FreeMemory '' ' Search the controls on the form for one that matches "ActCtrl" '' For Each Control In Form.Controls '' If Control.hWnd = ActCtrl Then '' If Err Then '' Err.Clear '' Err.Number = 0 '' Else '' Set ActiveControl = Control '' GoTo FreeMemory '' End If '' End If '' Next Else GoTo FreeMemory End If FreeMemory: Set Form = Nothing Set Control = Nothing End Property ' Returns the handle to the currently active window (not restricted to the current ' process like "ActiveForm" / "ActiveControl") Public Property Get ActiveWindow() As Long ActiveWindow = GetForegroundWindow If ActiveWindow = 0 Then ErrorHandler App.EXEName & ".cScreen.ActiveWindow(GetForegroundWindow)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If End Property ' Returns the handle to the active control or object on the currently active window ' (not restricted to the current process like "ActiveForm" / "ActiveControl") Public Property Get ActiveObject() As Long Dim ActWin As Long Dim ActObj As Long ' Get which window is the forground (active) window ActWin = GetForegroundWindow ' Make sure that the return was valid If ActWin = 0 Then ErrorHandler App.EXEName & ".cScreen.ActiveObject(GetForegroundWindow)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Exit Property End If ' Attach the thread of the specified window to the thread of this program ' so that the GetFocus API can be correctly called to get the active control ' for that window. AttachThread ActWin, True ' Get the active object on the active window ActiveObject = GetFocus ' Dettach the thread from this one AttachThread ActWin, False End Property 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXX XXXX 'XXXX THE FOLLOWING ARE SUPPORT FUNCTIONS USED ONLY WITHIN THIS MODULE XXXX 'XXXX XXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ' This is the routine that handles reporting all errors that occur for this module... ' both VB errors and API errors Private Sub ErrorHandler(ByVal Err_Source As String, ByVal Err_Number As Long, ByVal Err_Description As String) Debug.Print "ERROR - Number = " & CStr(Err_Number) & ", Description = " & Err_Description If Err_Number <> 0 Then Err.Raise Err_Number, Err_Source, Err_Description End If End Sub ' Creates a logical pen with the specified information ' ------------------------------------------------------------------------------------------- ' * IMPORTANT - The routine that calls this function needs to free the created pen ' by calling the DeleteObject API with the value returned by the "Return_Handle" parameter ' ------------------------------------------------------------------------------------------- Private Function GetPen(ByVal PenColor As Long, ByRef Return_Handle As Long) As Boolean ' Dim LPen As LOGPEN ' ' With LPen ' .lopnColor = ClrCurrent ' .lopnStyle = ThePenStyle ' .lopnWidth.X = ThePenWidth ' End With ' VarCurrent = CreatePenIndirect(LPen) Return_Handle = CreatePen(s_PenStyle, s_PenWidth, PenColor) If Return_Handle = 0 Then ErrorHandler App.EXEName & ".cScreen.GetPen(CreatePen)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Else GetPen = True End If End Function ' Creates a logical brush with the specified information ' ------------------------------------------------------------------------------------------- ' * IMPORTANT - The routine that calls this function needs to free the created brush ' by calling the DeleteObject API with the value returned by the "Return_Handle" parameter ' ------------------------------------------------------------------------------------------- Private Function GetBrush(ByVal BrushColor As Long, ByRef Return_Handle As Long) As Boolean Dim LBrush As LOGBRUSH With LBrush .lbColor = BrushColor .lbHatch = s_BrushHatch .lbStyle = s_BrushStyle End With Return_Handle = CreateBrushIndirect(LBrush) If Return_Handle = 0 Then ErrorHandler App.EXEName & ".cScreen.GetBrush(CreateBrushIndirect)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Else GetBrush = True End If End Function ' Sets the foreground and background for the specified DC Private Function SetColors(ByVal hScreenDC As Long) As Boolean Dim TempBrush As Long Dim TempPen As Long ' Make sure the parameters are valid If hScreenDC = 0 Then ErrorHandler App.EXEName & ".cScreen.SetDisplayFont", -1, "Invalid DC Specified" Exit Function End If ' Set the text background color of the screen If SetTextBackColor(hScreenDC, s_BackColor_Txt) = &HFFFFFFFF Then ErrorHandler App.EXEName & ".cScreen.SetColors(SetTextBackColor)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Exit Function End If ' Set the text foreground color of the screen If SetTextForeColor(hScreenDC, s_ForeColor_Txt) = &HFFFFFFFF Then ErrorHandler App.EXEName & ".cScreen.SetColors(SetTextForeColor)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Exit Function End If ' Set the screen's background color of the screen If GetBrush(s_BackColor_Scr, TempBrush) = True Then DeleteObject SelectObject(hScreenDC, TempBrush) ' This line selects in the new brush and deletes the old one - memory clean up End If ' Set the screen's forecolor color of the screen If GetPen(s_ForeColor_Scr, TempPen) = True Then DeleteObject SelectObject(hScreenDC, TempPen) ' This line selects in the new brush and deletes the old one - memory clean up End If SetColors = True End Function ' This function itterates through all the existing devices on the current system and ' gets their name and description. This only works for Win98 and Win2000. Private Function GetDevices() As Boolean On Error GoTo ErrorTrap Dim DD As DISPLAY_DEVICE Dim MyCounter As Long Dim ReturnValue As Long Dim DeviceIndex As Long ReturnValue = 1 DeviceIndex = -1 s_DeviceCount = 0 Erase s_DeviceName Erase s_DeviceStr While ReturnValue <> 0 DeviceIndex = DeviceIndex + 1 ClearDDVariable DD DD.cb = Len(DD) ReturnValue = EnumDisplayDevices(vbNullString, DeviceIndex, DD, 0) If ReturnValue <> 0 Then s_DeviceCount = s_DeviceCount + 1 ReDim Preserve s_DeviceName(s_DeviceCount - 1) As String ReDim Preserve s_DeviceStr(s_DeviceCount - 1) As String s_DeviceName(s_DeviceCount - 1) = Left(DD.DeviceName, InStr(DD.DeviceName, Chr(0)) - 1) s_DeviceStr(s_DeviceCount - 1) = Left(DD.DeviceString, InStr(DD.DeviceString, Chr(0)) - 1) End If Wend GetDevices = True Exit Function ErrorTrap: If Err.Number = 0 Then ' No Error Resume Next ElseIf Err.Number = 20 Then ' Resume Without Error Resume Next ElseIf Err.Number = 49 Then ' Bad DLL Calling Convention (EnumDisplayDevices only available under Win98 & Win2000 Err.Clear Err.Number = 0 GetDevices = True Exit Function Else ' Unknown Error ErrorHandler App.EXEName & ".cScreen.GetDevices", Err.Number, Err.Description s_DeviceCount = 1 ReDim s_DeviceName(0) As String ReDim s_DeviceStr(0) As String GetDevices = False Err.Clear Exit Function End If End Function ' This function is part of the "GetDevices" function Private Function ClearDDVariable(ByRef DD As DISPLAY_DEVICE) DD.cb = 0 'As Long DD.DeviceName = String(32, Chr(0)) 'As String * 31 DD.DeviceString = String(127, Chr(0)) 'As String * 127 DD.StateFlags = 0 'As Long DD.DeviceID = String(127, Chr(0)) 'As String * 127 DD.DeviceKey = String(127, Chr(0)) 'As String * 127 End Function ' This function get all the general information about the screen Private Function GetDisplayInfo(ByVal hScreenDC As Long) As Boolean On Error Resume Next Dim TempW As Long Dim TempH As Long ' Make sure the parameters are valid If hScreenDC = 0 Then ErrorHandler App.EXEName & ".cScreen.SetDisplayFont", -1, "Invalid DC Specified" Exit Function End If ' Get the color depth s_BitsPerPixel = GetDeviceCaps(hScreenDC, BITSPIXEL) ' Get the screen width / height in pixels s_Width = CSng(GetDeviceCaps(hScreenDC, HORZRES)) s_Height = CSng(GetDeviceCaps(hScreenDC, VERTRES)) ' Get the physical width / height of the screen in millimeters TempH = GetDeviceCaps(hScreenDC, VERTSIZE) TempW = GetDeviceCaps(hScreenDC, HORZSIZE) ' Get the TwipsPerPixelX & TwipsPerPixelY (There are 56.7 twips per millimeter) s_TwipsX = CSng((56.7 * TempW) / s_Width) s_TwipsY = CSng((56.7 * TempH) / s_Height) GetDisplayInfo = True End Function ' Function that retrieves all of the available fonts for the screen Private Function GetFontInfo(ByVal hScreenDC As Long) As Boolean Dim TempLOGFONT As LOGFONT ' Make sure the parameters are valid If hScreenDC = 0 Then ErrorHandler App.EXEName & ".cScreen.SetDisplayFont", -1, "Invalid DC Specified" Exit Function End If ' If EnumFontFamilies(hScreenDC, vbNullString, AddressOf EnumFontFamProc, 0) <> 0 Then ' GetFontInfo = True ' End If If EnumFontFamiliesEx(hScreenDC, TempLOGFONT, AddressOf EnumFontFamExProc, 0, 0) <> 0 Then GetFontInfo = True End If End Function ' Function that converts automation colors such as "vbButtonFace" to standard ' color such as "12632256". It is safest to pass all colors through this ' function to make sure that if a user passes a color like "Me.BackColor" and ' the BackColor is vbButtonFace, it won't mess up any of the API's that are ' expecting a normal color value. Private Function TranslateColor(ByVal oClr As Long, Optional ByVal hPal As Long = 0) As Long On Error Resume Next If OleTranslateColor(oClr, hPal, TranslateColor) <> 0 Then ErrorHandler App.EXEName & ".cScreen.TranslateColor(OleTranslateColor)", Err.LastDllError, GetErrorMsg(Err.LastDllError) TranslateColor = -1 End If End Function ' This function attaches or detaches the specified thread to the current thread so that APIs like ' GetFocus (which only works within the current process) can be utilised. Private Function AttachThread(ByVal TargetHandle As Long, ByVal Attach As Boolean) As Boolean Dim ThisThread As Long Dim NewThread As Long ' Check to see if the specified handle is valid If TargetHandle = 0 Then Exit Function End If ' Get the current thread ThisThread = GetCurrentThreadId If ThisThread = 0 Then ErrorHandler App.EXEName & ".cScreen.AttachThread(GetCurrentThreadId)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Exit Function End If ' Get the tread of the specified window NewThread = GetWindowThreadProcessId(TargetHandle, 0) If NewThread = 0 Then ErrorHandler App.EXEName & ".cScreen.AttachThread(GetWindowThreadProcessId)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Exit Function End If ' Make sure that the threads aren't the same If ThisThread = NewThread Then AttachThread = True Exit Function End If ' Attach the new thread to this one If Attach = True Then If AttachThreadInput(NewThread, ThisThread, 1) <> 0 Then AttachThread = True Else ErrorHandler App.EXEName & ".cScreen.AttachThread(AttachThreadInput)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If Else If AttachThreadInput(NewThread, ThisThread, 0) <> 0 Then AttachThread = True Else ErrorHandler App.EXEName & ".cScreen.AttachThread(AttachThreadInput)", Err.LastDllError, GetErrorMsg(Err.LastDllError) End If End If End Function ' Gets the Windows error description based on the windows error number Private Function GetErrorMsg(ByVal ErrorNumber As Long) As String Dim strMessage As String Dim lngFlags As Long ' Set the proper flags lngFlags = FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS ' Return the error message associated with the specified error number strMessage = String(MAX_PATH, Chr(0)) FormatMessage lngFlags, 0, ErrorNumber, 0&, strMessage, MAX_PATH, ByVal 0 GetErrorMsg = Left(strMessage, InStr(strMessage, Chr(0)) - 1) If Right(GetErrorMsg, 2) = vbCrLf Then GetErrorMsg = Left(GetErrorMsg, Len(GetErrorMsg) - 2) End If End Function ' Returns a handle to the specified font type Private Function GetFont(ByVal hScreenDC As Long, ByRef TheFontInfo As FontInfo, ByRef Return_Handle As Long) As Boolean Dim TheHeight As Long Dim TheItalic As Long Dim TheUnderline As Long Dim TheStrikeThru As Long Dim TheWeight As Long Dim hFont As Long ' Check the parameters to make sure they are valid If TheFontInfo.fontName = "" Then ErrorHandler App.EXEName & ".cScreen.GetFont", -1, "Invalid Font Name Specified" Exit Function ElseIf TheFontInfo.PointSize = 0 Then ErrorHandler App.EXEName & ".cScreen.GetFont", -1, "Invalid Font Size Specified" Exit Function ElseIf hScreenDC = 0 Then ErrorHandler App.EXEName & ".cScreen.GetFont", -1, "Invalid DC Specified" Exit Function End If ' Set the correct numbers to pass the function TheHeight = -MulDiv(TheFontInfo.PointSize, GetDeviceCaps(hScreenDC, LOGPIXELSY), 72) If TheFontInfo.Bold = True Then TheWeight = 700 Else TheWeight = 400 If TheFontInfo.Italic = True Then TheItalic = 1 If TheFontInfo.Underline = True Then TheUnderline = 1 If TheFontInfo.StrikeThru = True Then TheStrikeThru = 1 ' Create the font Return_Handle = CreateFont(TheHeight, 0, 0, 0, TheWeight, TheItalic, TheUnderline, TheStrikeThru, 1, 0, 0, 0, 0, TheFontInfo.fontName) If Return_Handle = 0 Then ErrorHandler App.EXEName & ".cScreen.GetFont(CreateFont)", Err.LastDllError, GetErrorMsg(Err.LastDllError) Else GetFont = True End If End Function ' Function that takes the specified font handle and selects it into the specified screen DC Private Function SetDisplayFont(ByVal hScreenDC As Long, ByVal hFont As Long) As Boolean Dim ReturnValue As Long ' Make sure the If hScreenDC = 0 Then ErrorHandler App.EXEName & ".cScreen.SetDisplayFont", -1, "Invalid DC Specified" Exit Function ElseIf hFont = 0 Then ErrorHandler App.EXEName & ".cScreen.SetDisplayFont", -1, "Invalid Font Handle Specified" Exit Function End If ' Select the font into ReturnValue = SelectObject(hScreenDC, hFont) If ReturnValue <> 0 Then DeleteObject ReturnValue SetDisplayFont = True End If End Function ' Delete all record of previously drawn items Private Sub DeleteDrawInfo() On Error Resume Next Erase DArcInfo() Erase DEllipseInfo() Erase DHalfCircleInfo() Erase DLine() Erase DPicture() Erase DPie() Erase DPolygon() Erase DPolyline() Erase DRectangle() Erase DText() DArcInfoCount = 0 DEllipseInfoCount = 0 DHalfCircleInfoCount = 0 DLineCount = 0 DPictureCount = 0 DPieCount = 0 DPolygonCount = 0 DPolylineCount = 0 DRectangleCount = 0 DTextCount = 0 End Sub Function PictureFromHandle(ByVal hBitmap As Long, Optional ByVal hPalette As Long = 0) As StdPicture Dim ReturnValue As Long Dim PicInfo As PicBmp Dim ThePicture As StdPicture ' IPicture Dim IID_IDispatch As GUID ' Fill GUID info With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With ' Fill picture info With PicInfo .Size = Len(PicInfo) ' Length of structure .Type = vbPicTypeBitmap ' Type of Picture .hBmp = hBitmap ' Handle to bitmap .hPal = hPalette ' Handle to palette (May be NULL) End With ' Create the picture ReturnValue = OleCreatePictureIndirect(PicInfo, IID_IDispatch, 1, ThePicture) If ReturnValue <> S_OK Then GoTo ErrorTrap End If ' Return the new picture Set PictureFromHandle = ThePicture Exit Function ErrorTrap: Select Case ReturnValue Case E_NOINTERFACE ErrorHandler App.EXEName & ".cScreen.PictureFromHandle(OleCreatePictureIndirect)", ReturnValue, "The object does not support the interface specified in riid." Case E_POINTER ErrorHandler App.EXEName & ".cScreen.PictureFromHandle(OleCreatePictureIndirect)", ReturnValue, "The address in pPictDesc or ppvObj is not valid. For example, it may be NULL." Case E_INVALIDARG ErrorHandler App.EXEName & ".cScreen.PictureFromHandle(OleCreatePictureIndirect)", ReturnValue, "One or more arguments are invalid." Case E_OUTOFMEMORY ErrorHandler App.EXEName & ".cScreen.PictureFromHandle(OleCreatePictureIndirect)", ReturnValue, "Ran out of memory." Case E_UNEXPECTED ErrorHandler App.EXEName & ".cScreen.PictureFromHandle(OleCreatePictureIndirect)", ReturnValue, "Catastrophic Failure." Case Else ErrorHandler App.EXEName & ".cScreen.PictureFromHandle(OleCreatePictureIndirect)", ReturnValue, "Unknown Error." End Select End Function