home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / bsGradient621303142002.psc / bsGradientLabel / modDeclares.bas < prev   
Encoding:
BASIC Source File  |  2002-03-05  |  1.7 KB  |  67 lines
  1. Attribute VB_Name = "Module1"
  2. Type LOGFONT
  3.   lfHeight As Long
  4.   lfWidth As Long
  5.   lfEscapement As Long
  6.   lfOrientation As Long
  7.   lfWeight As Long
  8.   lfItalic As Byte
  9.   lfUnderline As Byte
  10.   lfStrikeOut As Byte
  11.   lfCharSet As Byte
  12.   lfOutPrecision As Byte
  13.   lfClipPrecision As Byte
  14.   lfQuality As Byte
  15.   lfPitchAndFamily As Byte
  16. ' lfFaceName(LF_FACESIZE) As Byte 'THIS WAS DEFINED IN API-CHANGES MY OWN
  17.   lfFacename As String * 33
  18. End Type
  19.  
  20. Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
  21. Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  22. Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  23.  
  24.  
  25. Private Sub FontStuff()
  26.   On Error GoTo GetOut
  27.   Me.Cls
  28.   Dim F As LOGFONT, hPrevFont As Long, hFont As Long, FontName As String
  29.   Dim FONTSIZE As Integer
  30.   FONTSIZE = Val(txtSize.Text)
  31.  
  32.   F.lfEscapement = 10 * Val(txtDegree.Text) 'rotation angle, in tenths
  33.   FontName = "Arial Black" + Chr$(0) 'null terminated
  34.   F.lfFacename = FontName
  35.   F.lfHeight = (FONTSIZE * -20) / Screen.TwipsPerPixelY
  36.   hFont = CreateFontIndirect(F)
  37.   hPrevFont = SelectObject(Me.hdc, hFont)
  38.   CurrentX = 3930
  39.   CurrentY = 3860
  40.   Print "SParq"
  41.   
  42. '  Clean up, restore original font
  43.   hFont = SelectObject(Me.hdc, hPrevFont)
  44.   DeleteObject hFont
  45.   
  46.   Exit Sub
  47. GetOut:
  48.   Exit Sub
  49.  
  50. End Sub
  51.  
  52. Private Sub Command1_Click()
  53.   FontStuff
  54. End Sub
  55.  
  56.  
  57. Private Sub txtDegree_Change()
  58.    If Val(txtDegree) < 1 Then txtDegree = 1: Exit Sub
  59.    If Val(txtDegree) > 360 Then txtDegree = 360: Exit Sub
  60.    Command1_Click
  61. End Sub
  62.  
  63. Private Sub txtsize_Change()
  64.   If Not IsNumeric(txtSize.Text) Then txtSize.Text = "18"
  65. End Sub
  66.  
  67.