home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / vb_code1 / bar_vbx / module1.bas < prev    next >
BASIC Source File  |  1993-12-20  |  9KB  |  275 lines
  1. Type DOCINFO
  2.    cbSize As Integer
  3.    DocName As Long
  4.    Output As Long
  5. End Type
  6.  
  7. Global Const LF_FACESIZE = 32
  8.  
  9. Type LOGFONT
  10.     lfHeight As Integer
  11.     lfWidth As Integer
  12.     lfEscapement As Integer
  13.     lfOrientation As Integer
  14.     lfWeight As Integer
  15.     lfItalic As String * 1
  16.     lfUnderline As String * 1
  17.     lfStrikeOut As String * 1
  18.     lfCharSet As String * 1
  19.     lfOutPrecision As String * 1
  20.     lfClipPrecision As String * 1
  21.     lfQuality As String * 1
  22.     lfPitchAndFamily As String * 1
  23.     lfFaceName As String * LF_FACESIZE
  24. End Type
  25.  
  26. Global Const OUT_DEFAULT_PRECIS = 0
  27. Global Const OUT_STRING_PRECIS = 1
  28. Global Const OUT_CHARACTER_PRECIS = 2
  29. Global Const OUT_STROKE_PRECIS = 3
  30.  
  31. Global Const CLIP_DEFAULT_PRECIS = 0
  32. Global Const CLIP_CHARACTER_PRECIS = 1
  33. Global Const CLIP_STROKE_PRECIS = 2
  34.  
  35. Global Const DEFAULT_QUALITY = 0
  36. Global Const DRAFT_QUALITY = 1
  37. Global Const PROOF_QUALITY = 2
  38.  
  39. Global Const DEFAULT_PITCH = 0
  40. Global Const FIXED_PITCH = 1
  41. Global Const VARIABLE_PITCH = 2
  42.  
  43. Global Const ANSI_CHARSET = 0
  44. Global Const SYMBOL_CHARSET = 2
  45. Global Const SHIFTJIS_CHARSET = 128
  46. Global Const OEM_CHARSET = 255
  47.  
  48. '  Font Families
  49. '
  50. Global Const FF_DONTCARE = 0    '  Don't care or don't know.
  51. Global Const FF_ROMAN = 16  '  Variable stroke width, serifed.
  52.  
  53. '  Times Roman, Century Schoolbook, etc.
  54. Global Const FF_SWISS = 32  '  Variable stroke width, sans-serifed.
  55.  
  56. '  Helvetica, Swiss, etc.
  57. Global Const FF_MODERN = 48 '  Constant stroke width, serifed or sans-serifed.
  58.  
  59. '  Pica, Elite, Courier, etc.
  60. Global Const FF_SCRIPT = 64 '  Cursive, etc.
  61. Global Const FF_DECORATIVE = 80 '  Old English, etc.
  62.  
  63. '  Font Weights
  64. Global Const FW_DONTCARE = 0
  65. Global Const FW_THIN = 100
  66. Global Const FW_EXTRALIGHT = 200
  67. Global Const FW_LIGHT = 300
  68. Global Const FW_NORMAL = 400
  69. Global Const FW_MEDIUM = 500
  70. Global Const FW_SEMIBOLD = 600
  71. Global Const FW_BOLD = 700
  72. Global Const FW_EXTRABOLD = 800
  73. Global Const FW_HEAVY = 900
  74.  
  75. Global Const FW_ULTRALIGHT = FW_EXTRALIGHT
  76. Global Const FW_REGULAR = FW_NORMAL
  77. Global Const FW_DEMIBOLD = FW_SEMIBOLD
  78. Global Const FW_ULTRABOLD = FW_EXTRABOLD
  79. Global Const FW_BLACK = FW_HEAVY
  80.  
  81. Global Const GMEM_MOVEABLE = &H2
  82. Global Const GMEM_ZEROINIT = &H40
  83. Global Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
  84.  
  85. Global Const PD_RETURNDC = &H100&
  86. Global Const PD_PRINTSETUP = &H40&
  87.  
  88. Global Const LOGPIXELSX = 88
  89. Global Const LOGPIXELSY = 90
  90.  
  91. Global hTextFont As Integer, hDataFont As Integer, hCompanyFont As Integer
  92. Global Font As LOGFONT
  93. Global hPen As Integer
  94.  
  95. Declare Function StartDoc Lib "GDI" (ByVal hDC As Integer, lpdi As DOCINFO) As Integer
  96. Declare Function EndPage Lib "GDI" (ByVal hDC As Integer) As Integer
  97. Declare Function EndDocAPI Lib "GDI" Alias "EndDoc" (ByVal hDC As Integer) As Integer
  98. Declare Function StartPage Lib "GDI" (ByVal hDC As Integer) As Integer
  99. Declare Function TextOut Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal lpString As String, ByVal nCount As Integer) As Integer
  100. Declare Function GlobalAlloc Lib "Kernel" (ByVal wFlags As Integer, ByVal dwBytes As Long) As Integer
  101. Declare Function GlobalLock Lib "Kernel" (ByVal hMem As Integer) As Long
  102. Declare Function DeleteDC Lib "GDI" (ByVal hDC As Integer) As Integer
  103. Declare Sub hmemcpy Lib "Kernel" (lpDest As Any, lpSource As Any, ByVal dwBytes As Long)
  104. Declare Function TextOut Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal lpString As String, ByVal nCount As Integer) As Integer
  105. Declare Function SelectObject Lib "GDI" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
  106. Declare Function CreateFontIndirect Lib "GDI" (lpLogFont As LOGFONT) As Integer
  107. Declare Sub DeleteObject Lib "GDI" (ByVal Object%)
  108. Declare Function MoveTo Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer) As Long
  109. Declare Function LineTo Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer) As Integer
  110. Declare Function CreatePen Lib "GDI" (ByVal nPenStyle As Integer, ByVal nWidth As Integer, ByVal crColor As Long) As Integer
  111. Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
  112.  
  113. Sub CreateObjects ()
  114.         Font.lfHeight = 35
  115.         Font.lfWidth = 0
  116.         Font.lfEscapement = 0
  117.         Font.lfOrientation = 0
  118.         Font.lfWeight = FW_NORMAL
  119.         Font.lfItalic = Chr$(0)
  120.         Font.lfUnderline = Chr$(0)
  121.         Font.lfStrikeOut = Chr$(0)
  122.         Font.lfCharSet = Chr$(ANSI_CHARSET)
  123.         Font.lfOutPrecision = Chr$(0)
  124.         Font.lfClipPrecision = Chr$(0)
  125.         Font.lfQuality = Chr$(PROOF_QUALITY)
  126.         Font.lfPitchAndFamily = Chr$(DEFAULT_PITCH)
  127.         Font.lfFaceName = Chr$(0)
  128.   
  129.         hTextFont = CreateFontIndirect(Font)
  130.  
  131.         Font.lfHeight = 70
  132.         Font.lfWidth = 0
  133.         Font.lfEscapement = 0
  134.         Font.lfOrientation = 0
  135.         Font.lfWeight = FW_SEMIBOLD
  136.         Font.lfItalic = Chr$(0)
  137.         Font.lfUnderline = Chr$(0)
  138.         Font.lfStrikeOut = Chr$(0)
  139.         Font.lfCharSet = Chr$(0)
  140.         Font.lfOutPrecision = Chr$(0)
  141.         Font.lfClipPrecision = Chr$(0)
  142.         Font.lfQuality = Chr$(PROOF_QUALITY)
  143.         Font.lfPitchAndFamily = Chr$(DEFAULT_PITCH)
  144.         Font.lfFaceName = "Arial"
  145.  
  146.         hDataFont = CreateFontIndirect(Font)
  147.  
  148.         Font.lfHeight = 28
  149.         Font.lfWidth = 0
  150.         Font.lfEscapement = 0
  151.         Font.lfOrientation = 0
  152.         Font.lfWeight = FW_SEMIBOLD
  153.         Font.lfItalic = Chr$(0)
  154.         Font.lfUnderline = Chr$(0)
  155.         Font.lfStrikeOut = Chr$(0)
  156.         Font.lfCharSet = Chr$(ANSI_CHARSET)
  157.         Font.lfOutPrecision = Chr$(0)
  158.         Font.lfClipPrecision = Chr$(0)
  159.         Font.lfQuality = Chr$(PROOF_QUALITY)
  160.         Font.lfPitchAndFamily = Chr$(DEFAULT_PITCH)
  161.         Font.lfFaceName = Chr$(0)
  162.   
  163.         hCompanyFont = CreateFontIndirect(Font)
  164.  
  165.         hPen = CreatePen(0, 3, &HFFFFFF00)
  166. End Sub
  167.  
  168. Sub DeleteObjects ()
  169.         DeleteObject hTextFont
  170.         DeleteObject hDataFont
  171.         DeleteObject hCompanyFont
  172.         DeleteObject hPen
  173. End Sub
  174.  
  175. Sub LineToScale (ByVal hDC As Integer, x As Integer, y As Integer, theScaleMode As Integer)
  176.     Dim xPos As Integer, yPos As Integer, VertRes As Integer, HorzRes As Integer
  177.  
  178.     VertRes = GetDeviceCaps(hDC, LOGPIXELSY)
  179.     HorzRes = GetDeviceCaps(hDC, LOGPIXELSX)
  180.  
  181.     Select Case theScaleMode
  182.         Case 1 ' Twip
  183.             xPos = (x / 1440) * HorzRes
  184.             yPos = (y / 1440) * VertRes
  185.         Case 2: ' Point
  186.             xPos = (x / 72) * HorzRes
  187.             yPos = (y / 72) * VertRes
  188.         Case 4: ' Character
  189.             xPos = (x / 12) * HorzRes
  190.             yPos = (y / 6) * VertRes
  191.         Case 5: ' Inch
  192.             xPos = x * HorzRes
  193.             yPos = y * VertRes
  194.         Case 6: ' Millimeter
  195.             xPos = (x * .03937) * HorzRes
  196.             yPos = (y * .03937) * VertRes
  197.         Case 7: ' Centimeter
  198.             xPos = (x * .3937) * HorzRes
  199.             yPos = (y * .3937) * VertRes
  200.         Case Else
  201.             xPos = x
  202.             yPos = y
  203.     End Select
  204.  
  205.     Ok = LineTo(hDC, xPos, yPos)
  206. End Sub
  207.  
  208. Sub MoveToScale (ByVal hDC As Integer, x As Integer, y As Integer, theScaleMode As Integer)
  209.     Dim xPos As Integer, yPos As Integer, VertRes As Integer, HorzRes As Integer
  210.  
  211.     VertRes = GetDeviceCaps(hDC, LOGPIXELSY)
  212.     HorzRes = GetDeviceCaps(hDC, LOGPIXELSX)
  213.  
  214.     Select Case theScaleMode
  215.         Case 1 ' Twip
  216.             xPos = (x / 1440) * HorzRes
  217.             yPos = (y / 1440) * VertRes
  218.         Case 2: ' Point
  219.             xPos = (x / 72) * HorzRes
  220.             yPos = (y / 72) * VertRes
  221.         Case 4: ' Character
  222.             xPos = (x / 12) * HorzRes
  223.             yPos = (y / 6) * VertRes
  224.         Case 5: ' Inch
  225.             xPos = x * HorzRes
  226.             yPos = y * VertRes
  227.         Case 6: ' Millimeter
  228.             xPos = (x * .03937) * HorzRes
  229.             yPos = (y * .03937) * VertRes
  230.         Case 7: ' Centimeter
  231.             xPos = (x * .3937) * HorzRes
  232.             yPos = (y * .3937) * VertRes
  233.         Case Else
  234.             xPos = x
  235.             yPos = y
  236.     End Select
  237.  
  238.     Ok = MoveTo(hDC, xPos, yPos)
  239. End Sub
  240.  
  241. Sub PrintText (ByVal hDC As Integer, ByVal OutStr As String, x As Single, y As Single, hFont As Integer, theScaleMode As Integer)
  242.     Dim xPos As Integer, yPos As Integer, VertRes As Integer, HorzRes As Integer
  243.  
  244.     VertRes = GetDeviceCaps(hDC, LOGPIXELSY)
  245.     HorzRes = GetDeviceCaps(hDC, LOGPIXELSX)
  246.  
  247.     Select Case theScaleMode
  248.         Case 1 ' Twip
  249.             xPos = (x / 1440) * HorzRes
  250.             yPos = (y / 1440) * VertRes
  251.         Case 2: ' Point
  252.             xPos = (x / 72) * HorzRes
  253.             yPos = (y / 72) * VertRes
  254.         Case 4: ' Character
  255.             xPos = (x / 12) * HorzRes
  256.             yPos = (y / 6) * VertRes
  257.         Case 5: ' Inch
  258.             xPos = x * HorzRes
  259.             yPos = y * VertRes
  260.         Case 6: ' Millimeter
  261.             xPos = (x * .03937) * HorzRes
  262.             yPos = (y * .03937) * VertRes
  263.         Case 7: ' Centimeter
  264.             xPos = (x * .3937) * HorzRes
  265.             yPos = (y * .3937) * VertRes
  266.         Case Else
  267.             xPos = x
  268.             yPos = y
  269.     End Select
  270.  
  271.     Ok = SelectObject(hDC, hFont)
  272.     Ok = TextOut(hDC, xPos, yPos, OutStr, Len(OutStr))
  273. End Sub
  274.  
  275.