home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 25: Programming / pc_actual_25.iso / Delphi / PolarDraw / data1.cab / Samples / Visual_Basic / VBDraw / DrawVB.bas next >
Encoding:
BASIC Source File  |  2001-08-31  |  3.9 KB  |  133 lines
  1. Attribute VB_Name = "Draw"
  2. 'this module contains some functions and WinAPI declarations needed
  3. 'in this application: For displaying Open and SaveAs dialogs, ChooseColor
  4. 'dialog and some other functions
  5.  
  6. Public Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As TChooseColor) As Long
  7. Public Const CC_RGBINIT = &H1
  8.  
  9. Public Type TChooseColor
  10.         lStructSize As Long
  11.         hwndOwner As Long
  12.         hInstance As Long
  13.         rgbResult As Long
  14.         lpCustColors As String
  15.         flags As Long
  16.         lCustData As Long
  17.         lpfnHook As Long
  18.         lpTemplateName As String
  19. End Type
  20.  
  21.  
  22. Public Type POINTAPI
  23.         x As Long
  24.         y As Long
  25. End Type
  26.  
  27.     
  28. Type OPENFILENAME
  29.         lStructSize As Long
  30.         hwndOwner As Long
  31.         hInstance As Long
  32.         lpstrFilter As String
  33.         lpstrCustomFilter As String
  34.         nMaxCustFilter As Long
  35.         nFilterIndex As Long
  36.         lpstrFile As String
  37.         nMaxFile As Long
  38.         lpstrFileTitle As String
  39.         nMaxFileTitle As Long
  40.         lpstrInitialDir As String
  41.         lpstrTitle As String
  42.         flags As Long
  43.         nFileOffset As Integer
  44.         nFileExtension As Integer
  45.         lpstrDefExt As String
  46.         lCustData As Long
  47.         lpfnHook As Long
  48.         lpTemplateName As String
  49. End Type
  50.  
  51.    
  52. Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
  53. Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
  54. Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  55.  
  56. Public Function OpenPDRFile(strFilter) As String
  57. Dim fnFileName As OPENFILENAME
  58.  
  59.     With fnFileName
  60.         .lStructSize = Len(fnFileName)
  61.         .hwndOwner = 0
  62.         .lpstrDefExt = "*.pdr"
  63.         .nMaxFile = 256
  64.         .lpstrFilter = strFilter
  65.         .lpstrFile = String(255, " ")
  66.     End With
  67.     
  68.    If GetOpenFileName(fnFileName) Then
  69.         fnFileName.lpstrFile = RTrim(fnFileName.lpstrFile)
  70.         OpenPDRFile = fnFileName.lpstrFile
  71.    Else
  72.        OpenPDRFile = ""
  73.    End If
  74. End Function
  75. Public Function SavePDRFile(strFilter) As String
  76. Dim fnFileName As OPENFILENAME
  77.  
  78.     With fnFileName
  79.         .lStructSize = Len(fnFileName)
  80.         .hwndOwner = 0
  81.         .lpstrDefExt = "*.pdr"
  82.         .nMaxFile = 256
  83.         .lpstrFilter = strFilter
  84.         .lpstrFile = String(255, " ")
  85.     End With
  86.     
  87.     If GetSaveFileName(fnFileName) Then
  88.         fnFileName.lpstrFile = RTrim(fnFileName.lpstrFile)
  89.         SavePDRFile = fnFileName.lpstrFile
  90.    Else
  91.       SavePDRFile = ""
  92.    End If
  93. End Function
  94.  
  95.  
  96. Public Function SetColor(crInitColor As OLE_COLOR) As OLE_COLOR
  97. 'this function displays dialog box for choosing color and returns the color selected
  98.    
  99.    Dim CustomColours() As Byte      ' Define array for custom colours.
  100.    ReDim CustomColours(0 To 15) As Byte   ' Resize the array to hold the elements.
  101.    Dim structChooseColour As TChooseColor
  102.     
  103.    With structChooseColour
  104.        .hwndOwner = 0
  105.        .lpCustColors = StrConv(CustomColours, vbUnicode)
  106.        ' Pass the custom colours array after converting
  107.        ' it to Unicode using the StrConv function.
  108.        .rgbResult = crInitColor
  109.        .flags = CC_RGBINIT
  110.        .lStructSize = Len(structChooseColour)
  111.    End With
  112.    If ChooseColor(structChooseColour) <> 0 Then
  113.       SetColor = structChooseColour.rgbResult
  114.    Else
  115.       SetColor = crInitColor
  116.    End If
  117.     
  118. End Function
  119. Public Function NumberGreaterThanZero(varValue As Variant) As Boolean
  120.     
  121.     If IsNumeric(varValue) Then
  122.         If varValue > 0 Then
  123.             NumberGreaterThanZero = True
  124.             Exit Function
  125.         End If
  126.     End If
  127.         
  128.     MsgBox "You must enter a numeric value, greater than zero!", vbCritical
  129.     NumberGreaterThanZero = False
  130.     
  131. End Function
  132.  
  133.