home *** CD-ROM | disk | FTP | other *** search
/ PC Open 19 / pcopen19.iso / Imag / IMAGINE / CUSTOM.Z / ATTRIB.BAS < prev    next >
Encoding:
BASIC Source File  |  1997-04-04  |  8.0 KB  |  242 lines
  1. Attribute VB_Name = "modAttributes"
  2. Declare Function OSGetPrivateProfileString% Lib "Kernel32" Alias "GetPrivateProfileStringA" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal ReturnString$, ByVal NumBytes As Integer, ByVal FileName$)
  3. Declare Function OSWritePrivateProfileString% Lib "Kernel32" Alias "WritePrivateProfileStringA" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal FileName$)
  4. Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
  5. Declare Function OSTimeGetTime& Lib "WINMM.DLL" Alias "timeGetTime" ()
  6. Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
  7. Declare Function SQLDataSources% Lib "ODBC32.DLL" (ByVal henv&, ByVal fdir%, ByVal szDSN$, ByVal cbDSNMAx%, pcbDSN%, ByVal szDesc$, ByVal cbDescMax%, pcbDesc%)
  8.  
  9. 'For tool tips
  10. Public Const SW_SHOWNOACTIVATE As Long = 4&
  11. Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
  12.  
  13. 'For Always-On-Top switches
  14. Public Const conHwndTopmost = -1
  15. Public Const conHwndNoTopmost = -2
  16. Public Const conSwpNoActivate = &H10
  17. Public Const conSwpShowWindow = &H40
  18. Public Const SWP_NOMOVE = 2
  19. Public Const SWP_NOSIZE = 1
  20. Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE Or conSwpNoActivate
  21. Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
  22.  
  23.  
  24. Public f As frmMain
  25.  
  26.  
  27. Public blnRecordFormOpen As Boolean
  28. Public intVCount As Integer
  29. Public gPropObject As Object        'object to show properties on
  30.  
  31. Public objApp As Object
  32.  
  33. Public sDatabaseName As String
  34. Public sConnect As String
  35. Public gsCriteria As String
  36. Public gsTableName As String
  37.  
  38. Public gblnGraphicFound As Boolean
  39. Public gblnRecordFound As Boolean
  40.  
  41. Type AttributeTypes
  42.     DatabaseName As String
  43.     ConnectString As String
  44.     RecordSource As String
  45.     Field As String
  46.     Record As String
  47. End Type
  48.  
  49. Type Tables
  50.     TableName As String
  51.     TableHeading() As String
  52.     TableValue() As String
  53. End Type
  54.  
  55. Public garrTables() As String
  56. Public garrTableCollection() As Tables
  57. Public gintTablesCount As Integer
  58. Public gintTableCollectionCount As Integer
  59.  
  60. Public gDetachArray() As String
  61. Public gstrAttributeSetsArray() As String
  62. Public gobjDeleteAttributeSets As Object
  63. Public gdbCurrentDB As Database
  64.  
  65.  
  66. Public AttributeType As AttributeTypes
  67.  
  68. Type POINTAPI       ' Stores location of cursor
  69.    x As Long
  70.    Y As Long
  71. End Type
  72.  
  73. Global Const gnCTLARRAYHEIGHT = 340& '
  74.  
  75. Public gbFindFailed As Boolean
  76. Public gbFromTableView As Boolean
  77. Public mbNotFound As Boolean
  78. Public gsFindOp As String
  79. Public gsFindExpr As String
  80. Public gnFindType As Integer
  81. Public gsFindField As String
  82. Global Const gnEOF_ERR = 626                  '
  83.  
  84.  
  85. Declare Sub GetCursorPos Lib "user32" (lpPoint As POINTAPI)
  86. Declare Function GetActiveWindow Lib "user32" () As Long
  87.  
  88.  
  89. Sub Main()
  90. 'Needed when using command.ocx
  91. End Sub
  92. '--------------------------------------------------------------------------
  93. 'This function strips the file name off of a path/filename
  94. 'for use with ISAM databases that need the directory only
  95. '--------------------------------------------------------------------------
  96. Function StripFileName(rsFileName As String) As String
  97.   On Error Resume Next
  98.   Dim i As Integer
  99.  
  100.   For i = Len(rsFileName) To 1 Step -1
  101.     If Mid(rsFileName, i, 1) = "\" Then
  102.       Exit For
  103.     End If
  104.   Next
  105.   StripFileName = Mid(rsFileName, 1, i - 1)
  106. End Function
  107.  
  108. '*******************************************************
  109. '* Procedure Name: CenterForm                          *
  110. '*-----------------------------------------------------*
  111. '* Created: 2/10/94   By: VB Programmers Journal       *
  112. '* Modified: 4/24/94  By: David McCarter               *
  113. '*=====================================================*
  114. '*This code will center a form in the center of the    *
  115. '*screen. To use it, just call the sub and pass it the *
  116. '*form name [Call CenterForm main]                     *
  117. '*                                                     *
  118. '*                                                     *
  119. '*******************************************************
  120. Sub CenterForm(frmIN As Form)
  121.     Dim iTop As Integer, iLeft As Integer
  122.  
  123.     If frmIN.WindowState <> 0 Then Exit Sub
  124.     iTop = (Screen.Height - frmIN.Height) \ 2
  125.     iLeft = (Screen.Width - frmIN.Width) \ 2
  126.     
  127.     'If iTop And iLeft Then
  128.     frmIN.Move iLeft, iTop
  129.     'End If
  130. End Sub
  131.  
  132. Sub PrintToClipBoard()
  133.     Clipboard.Clear
  134.     Clipboard.SetText frmTextBox2.Text1.Text
  135.  
  136. End Sub
  137.  
  138. Sub PrintToFile()
  139.  
  140.     Dim nFreeFileNumber As Integer
  141.    
  142.     'Set Title of dialog box
  143.     f.dlgSave.DialogTitle = "Save Attribute Report As"
  144.     
  145.     'Set Filter on dialog box to display only text and *.* file types.
  146.     f.dlgSave.Filter = "Text Files (*.TXT)|*.TXT|All Files (*.*)|*.*"
  147.     
  148.     'Set Flags to remove read-only check box from dialog and prompt if chosen file exists.
  149.     f.dlgSave.FLAGS = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
  150.     
  151.     'Display the Dialog box.
  152.     On Error Resume Next
  153.     f.dlgSave.ShowSave
  154.     
  155.     If Err <> 32755 Then    ' User chose Cancel.
  156.     
  157.         nFreeFileNumber = FreeFile
  158.         Open f.dlgSave.FileName For Output As #nFreeFileNumber ' Create filename.
  159.             Print #nFreeFileNumber, frmTextBox2.Text1.Text  ' Output text.
  160.         Close #nFreeFileNumber   ' Close file.
  161.    
  162.     End If
  163.     
  164. End Sub
  165.  
  166. Sub LoadListView(nIndex As Integer)
  167.     Dim i As Integer
  168.     Dim j As Integer
  169.     Dim k As Integer
  170.     Dim itmX As Object
  171.     Dim blnHeadingPrinted As Boolean
  172.     
  173.     frmTextBox.lvreport.ColumnHeaders.Clear
  174.     frmTextBox.lvreport.ListItems.Clear
  175.     
  176.     
  177.     'Extract and handle data for that database table
  178.     For j = 1 To gintTableCollectionCount
  179.         If garrTableCollection(j).TableName = garrTables(nIndex) Then
  180.             If Not blnHeadingPrinted Then
  181.                 For k = 0 To UBound(garrTableCollection(j).TableHeading)
  182.                     frmTextBox.lvreport.ColumnHeaders.Add , , garrTableCollection(j).TableHeading(k)
  183.                     If (k + 1) = 1 Then
  184.                         Set itmX = frmTextBox.lvreport.ListItems.Add(, , garrTableCollection(j).TableValue(k))
  185.                     Else
  186.                         itmX.SubItems(k) = garrTableCollection(j).TableValue(k)
  187.                     End If
  188.                 Next k
  189.                 blnHeadingPrinted = True
  190.             Else
  191.                 For k = 0 To UBound(garrTableCollection(j).TableHeading)
  192.                     If (k + 1) = 1 Then
  193.                         Set itmX = frmTextBox.lvreport.ListItems.Add(, , garrTableCollection(j).TableValue(k))
  194.                     Else
  195.                         itmX.SubItems(k) = garrTableCollection(j).TableValue(k)
  196.                     End If
  197.                 Next k
  198.             End If
  199.         End If
  200.     Next j
  201.     blnHeadingPrinted = False
  202.  
  203. End Sub
  204. Sub SetHourglass()
  205.   DoEvents  'cause forms to repaint before going on
  206.   Screen.MousePointer = vbHourglass
  207. End Sub
  208. '------------------------------------------------------------
  209. 'this sub displays the error message with it's Err code
  210. 'and prompts to show the Errors collection if it
  211. 'is a data access type error
  212. '------------------------------------------------------------
  213. Sub ShowError()
  214.   Dim sTmp As String
  215.  
  216.   Screen.MousePointer = vbDefault
  217.  
  218.   sTmp = "The following Error occurred:" & gsNewLine & gsNewLine
  219.   'add the error string
  220.   sTmp = sTmp & Error & gsNewLine
  221.   'add the error number
  222.   sTmp = sTmp & "Number: " & Err
  223.   
  224.   Beep
  225.   'check to see if the error is from the db errors collection
  226.   If DBEngine.Errors.Count > 0 Then
  227.     If DBEngine.Errors(0).Number = Err Then
  228.       'add the prompt to display the errors collection
  229.       sTmp = sTmp & gsNewLine & gsNewLine
  230.       'beep and show the error
  231.       MsgBox sTmp, gnMSGBOX_TYPE
  232.     Else
  233.       MsgBox sTmp
  234.     End If
  235.   Else
  236.     MsgBox sTmp
  237.   End If
  238.  
  239. End Sub
  240.  
  241.  
  242.