modulemain.bas

VB远程操作Sql Server 2000数据库的工具 主要功能就是远程（局域网）操作Sql Server数据库。 包括： 搜索并列举局域网内的所有Sql Server服务器 搜索并列举Sql

Attribute VB_Name = "ModuleMain"


'关于
Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long

'取当前登录用户名
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'眼看花了吧？这么多参数？不要怕，很多参数都是NULL。NULL？就是vbNullString啦，其实就是个0。
'其中第3个参数lpFile就是我们要运行的文件名“d:\my test\test.exe”，第4个参数lpParameters就是命令行参数,
'最后一个参数就设为vbNormalFocus。其它的参数嘛，Long型的就设为0,String型的就设为vbNullString。

Declare Function SendMessageBynum& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Declare Function SendMessageByString& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String)
Public Const EM_LINEINDEX = &HBB '判断指定行第一个字符的编号
Public Const EM_LINELENGTH = &HC1 '判断一行长度
Public Const EM_GETLINE = &HC4 '从编辑控件取回…行的内容

Public Cns As New adodb.Connection '定义连接

Public Function CnnData(CurLocation As String, CnnProvider As String, SQLServerName As String, DatabasesName As String, UserID As String, LoadPassword As String, CnnPrompt As String, CnnTimeout As Long)
On Error GoTo errHandle

    With Cns   '定义连接
        .CursorLocation = adUseClient
        .Provider = "sqloledb"
        .Properties("Data Source").Value = SQLServerName
        .Properties("Initial Catalog").Value = DatabasesName
        .Properties("User ID") = UserID
        .Properties("Password") = LoadPassword
        .Properties("prompt") = adPromptNever
        .ConnectionTimeout = 15
        .Open
     End With
errHandle:
  If Err.Number <> 0 Then
    MsgBox "错误代码：" & Err.Number & vbCrLf & Err.Description
    'End
  End If
Err.Clear
 ' Resume Next
End Function

Function FieldType(nType As Integer) As String '定义字段类型
    Select Case nType
        Case 20
            FieldType = "bigint"
        Case 128
            FieldType = "Binary"
        Case 11
            FieldType = "bit"
        Case 129
            FieldType = "char"
        Case 135
            FieldType = "datetime"
        Case 131
            FieldType = "decimal"
        Case 5
            FieldType = "float"
        Case 205
            FieldType = "image"
        Case 3
            FieldType = "int"
        Case 6
            FieldType = "money"
        Case 130
            FieldType = "nchar"
        Case 203
            FieldType = "ntext"
        Case 131
            FieldType = "numeric"
        Case 202
            FieldType = "nvarchar"
        Case 4
            FieldType = "real"
        Case 135
            FieldType = "smalldatetime"
        Case 2
            FieldType = "smallint"
        Case 6
            FieldType = "smallmoney"
        Case 12
            FieldType = "sql_variant"
        Case 201
            FieldType = "text"
        Case 128
            FieldType = "timestamp"
        Case 17
            FieldType = "tinyint"
        Case 72
            FieldType = "uniqueidentifier"
        Case 204
            FieldType = "varbinary"
        Case 200
            FieldType = "varchar"
        Case Else
            FieldType = "自定义"
    End Select
End Function


Public Sub CheckExist(fm As Form) '防止程序重复加载
    Dim title As String
    
    If App.PrevInstance Then
        title = App.title
        
        App.title = "" '如此才不会Avtivate到自己
        
        fm.Caption = ""
        AppActivate title 'activate先前就已行的程式
        End
    End If
End Sub

Public Function File_Find(sFileName As String) As Boolean '判断文件是否存在
  If sFileName <> "" Then File_Find = (Dir(sFileName, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive) <> "")
End Function

Public Function Sqlstr(Files As String, Paths As String) '在SQLserver   中建立一个库
  
  'On   Error   GoTo   Err1
  
  'Sqlstr = ""
  'Sqlstr = Sqlstr & "CREATE DATABASE " & ComboDName.Text
  'Sqlstr = Sqlstr & " ON "
  'Sqlstr = Sqlstr & "(NAME='" & ComboDName.Text & "_dat'," '执行文件名
  'Sqlstr = Sqlstr & "FILENAME='" & Text1.Text & ComboDName.Text & "_dat.mdf',"
  'Sqlstr = Sqlstr & "SIZE=10MB," '文件的大小
  'Sqlstr = Sqlstr & "MAXSIZE=50MB," '可以增长到的最大大小
  'Sqlstr = Sqlstr & "FILEGROWTH=5MB)" '文件的增长增量
  'Sqlstr = Sqlstr & " LOG ON "
 ' Sqlstr = Sqlstr & "(NAME='" & ComboDName.Text & "_log',"
 ' Sqlstr = Sqlstr & "FILENAME='" & Text1.Text & ComboDName.Text & "_log.ldf',"
 ' Sqlstr = Sqlstr & "SIZE=5MB,"
 ' Sqlstr = Sqlstr & "MAXSIZE=25MB,"
 ' Sqlstr = Sqlstr & "FILEGROWTH=5MB)"
  
  
  Sqlstr = ""
  Sqlstr = Sqlstr & "CREATE DATABASE " & Files
  Sqlstr = Sqlstr & " ON "
  Sqlstr = Sqlstr & "(NAME='" & Files & "_dat'," '执行文件名
  Sqlstr = Sqlstr & "FILENAME='" & Paths & Files & "_Data.mdf')"
  Sqlstr = Sqlstr & " LOG ON "
  Sqlstr = Sqlstr & "(NAME='" & Files & "_log',"
  Sqlstr = Sqlstr & "FILENAME='" & Paths & Files & "_Log.ldf')"
        
End Function

Public Sub Delay(mSec As Long) '延迟申明
'  On Error GoTo ShowErr
  Dim TStart As Single
  TStart = Timer
  While (Timer - TStart) < (mSec / 1000)
    DoEvents
  Wend
  Exit Sub
'ShowErr:
  'Err.Clear
  'MsgBox Err.Source & "------" & Err.Description
'  Exit Sub
End Sub


Function Active_Enabled(FrmName As Form, TF As Boolean) As String '定义窗体控件的Enabled属性
'On Error Resume Next
  Dim Act As Control ' Control
  Select Case TF
    Case True
      'Delay (500)
      For Each Act In FrmName.Controls
        If TypeName(Act) = "CommandButton" And Act.Name <> "Command2" And Act.Name <> "Command3" Then
          Act.Enabled = True
          FrmName.Enabled = True
        End If
      Next
      
    Case False
      'Delay (500)
      For Each Act In FrmName.Controls
        If TypeName(Act) = "CommandButton" And Act.Name <> "Command2" And Act.Name <> "Command3" Then
          Act.Enabled = False
          FrmName.Enabled = False
        End If
      Next
  End Select
  
End Function

Function OpenPath(handle As Long, title As String, default As String) As String '选择文件夹
 On Error Resume Next
 Dim spShell, spFolder, spFolderItem
 Set spShell = CreateObject("Shell.Application")
 Set spFolder = spShell.BrowseForFolder(handle, title, 0, default)
 Set spFolderItem = spFolder.Self
 OpenPath = spFolderItem.Path
  
 If Err > 0 Then
 OpenPath = Empty
 Err.Clear
 End If
  
 Set spShell = Nothing
 Set spFolder = Nothing
 Set spFolderItem = Nothing
End Function
    
Function UText(SText As RichTextBox, FText As String)
  Dim Rt As Integer
  Dim Strt() As String
  Erase Strt
  Strt() = Split(FText, ";")
  
  For Rt = 0 To UBound(Strt)
    SText.Text = Replace(SText.Text, Strt(Rt), VBA.UCase(Strt(Rt)), , , 1)
  Next
End Function

Function OperatorList()
  FrmMain.Combo3.AddItem "="
  FrmMain.Combo3.AddItem ">"
  FrmMain.Combo3.AddItem "<"
  FrmMain.Combo3.AddItem "<>"
  FrmMain.Combo3.AddItem "LIKE"
  FrmMain.Combo3.AddItem "IN"
  FrmMain.Combo3.AddItem "BETWEEN"
  FrmMain.Combo3.AddItem "HAVING"
  FrmMain.Combo3.ListIndex = 0
End Function

Function OperatorInfor(OperList As String) As String
  Select Case OperList
    Case "="
      OperatorInfor = "字段中等于条件的记录（一般为数值型）...格式：字段名=" & VBA.Chr(34) & "条件" & VBA.Chr(34)
    Case ">"
      OperatorInfor = "字段中大于条件的记录（一般为数值型）...格式：字段名>" & VBA.Chr(34) & "条件" & VBA.Chr(34)
    Case "<"
      OperatorInfor = "字段中小于条件的记录（一般为数值型）...格式：字段名<" & VBA.Chr(34) & "条件" & VBA.Chr(34)
    Case "<>"
      OperatorInfor = "字段中不等于条件的记录（一般为数值型）...格式：字段名<>" & VBA.Chr(34) & "条件" & VBA.Chr(34)
    Case "LIKE"
      OperatorInfor = "字段中等于（包含）条件的记录（支持通配符）...格式：字段名 LIKE " & VBA.Chr(34) & "[%]条件[%]" & VBA.Chr(34)
    Case "IN"
      OperatorInfor = "字段中包含条件的记录...格式：字段名 IN (" & VBA.Chr(34) & "条件1" & VBA.Chr(34) & "," & VBA.Chr(34) & "条件2" & VBA.Chr(34) & "...)"
    Case "BETWEEN"
      OperatorInfor = "字段中介于两个条件之间的记录...格式：字段名 BETWEEN " & VBA.Chr(34) & "条件1" & VBA.Chr(34) & " AND " & VBA.Chr(34) & "条件2" & VBA.Chr(34)
    Case "HAVING"
      OperatorInfor = "字段中不等于条件的内容（支持函数条件）...格式：字段名 HAVING" & "(" & VBA.Chr(34) & "条件" & VBA.Chr(34) & ")"
  End Select
End Function

Function FieldTypeList()
  FrmEditFile.Combo1.AddItem "bigint"
  FrmEditFile.Combo1.AddItem "Binary"
  FrmEditFile.Combo1.AddItem "bit"
  FrmEditFile.Combo1.AddItem "char"
  FrmEditFile.Combo1.AddItem "datetime"
  FrmEditFile.Combo1.AddItem "decimal"
  FrmEditFile.Combo1.AddItem "float"
  FrmEditFile.Combo1.AddItem "image"
  FrmEditFile.Combo1.AddItem "int"
  FrmEditFile.Combo1.AddItem "money"
  FrmEditFile.Combo1.AddItem "nchar"
  FrmEditFile.Combo1.AddItem "ntext"
  FrmEditFile.Combo1.AddItem "numeric"
  FrmEditFile.Combo1.AddItem "nvarchar"
  FrmEditFile.Combo1.AddItem "real"
  FrmEditFile.Combo1.AddItem "smalldatetime"
  FrmEditFile.Combo1.AddItem "smallint"
  FrmEditFile.Combo1.AddItem "smallmoney"
  FrmEditFile.Combo1.AddItem "sql_variant"
  FrmEditFile.Combo1.AddItem "text"
  FrmEditFile.Combo1.AddItem "timestamp"
  FrmEditFile.Combo1.AddItem "tinyint"
  FrmEditFile.Combo1.AddItem "uniqueidentifier"
  FrmEditFile.Combo1.AddItem "varbinary"
  FrmEditFile.Combo1.AddItem "varchar"

End Function


Public Function ComputerNameGet() As String '获取计算机名
         Dim strComputerName As String
         Dim lngReturn As Long
         Dim lngStrLen As Long

         lngStrLen = 255
         strComputerName = VBA.String(255, " ") & VBA.Chr(0)
         lngReturn = GetComputerName(strComputerName, lngStrLen)
         If lngReturn = 0 Then
            ComputerNameGet = ""
        Else
            ComputerNameGet = VBA.Left$(strComputerName, InStr(strComputerName, VBA.Chr$(0)) - 1)
        End If
End Function

    
Public Function NTDomainUserName() As String
    Dim strBuffer As String * 255
    Dim lngBufferLength As Long
    Dim lngRet As Long
    Dim strTemp As String
    
    lngBufferLength = 255
    lngRet = GetUserName(strBuffer, lngBufferLength)
    strTemp = Trim$(strBuffer) ' UCase(Trim$(strBuffer))
    NTDomainUserName = Left$(strTemp, Len(strTemp) - 1)
    
End Function