pub.bas

OA编程 源代码

Attribute VB_Name = "Pub"

Public WebInfo(50, 3) As String
Public Curwebinfo(1, 3) As String



Public PubMdbConn As New ADODB.Connection
Public Pubsaconn As New ADODB.Connection

Public RstUser As New ADODB.Recordset

Public InstallPath As String

Private Const RootPath = "bkbtinfo"

Public Sevname As String
Public SevUser As String
Public Sevpwd As String
Public Curdb As String
Public dbName As String
Public Unitname As String
Public Ver As Integer

Public Const gstrSEP_URLDIR = "/"
Public Const gstrSEP_DIR = "\"


'定义公共变量
Public PubMdbConnstring As String '连接本地数据库
Public Pubsaconnstring As String '公共连接Sql Server串

Public PubSqlServeName As String 'Sql Server名称

Public WebName As String 'Web站点名称
Public Aimpath As String '备份路径

Public ImportPath As String
Public ExportPath As String

Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_VSCROLL = &H115
Public Const SB_BOTTOM = 7

Public SkinObj As SKINNOWLib.Skin

Public Function WebExist(NewWebName As String) As Integer
On Error GoTo err
Set WebServerRoot = GetObject("IIS://LocalHost/W3SVC/1/Root")
    For Each ExistVDir In WebServerRoot
        If LCase(ExistVDir.Name) = LCase(NewWebName) Then
            MsgBox "当前站点已经存在，请尝试别的名称！", 64
            Set ExistVDir = Nothing
            Set WebServerRoot = Nothing
            WebExist = 1
            Exit Function
        End If
    Next
 Set ExistVDir = Nothing
 Set WebServerRoot = Nothing
 Exit Function
err:

MsgBox "意外错误！(" & err.Description & ")", 64
Exit Function

End Function


Function SetIIS(Vpath) As Boolean
Dim WebServiceObj
Dim WebServerObj ' Get the web service object, which contains servers
Dim WebServerRoot
Dim VDir
Dim a, b
On Error GoTo ErrHandle
SetIIS = False
Set WebServiceObj = GetObject("IIS://LocalHost/W3SVC/1")
Set WebServerRoot = GetObject("IIS://LocalHost/W3SVC/1/Root")
Set VDir = WebServerRoot.Create("IIsWebVirtualDir", WebName)
VDir.AccessExecute = True


VDir.AccessRead = True         '读
VDir.AccessWrite = True '写

VDir.AccessScript = True
VDir.AccessSource = True

VDir.Path = Vpath     '指定路径
VDir.DefaultDoc = "default.asp"
VDir.AppCreate True    '创建虚拟目录
VDir.SetInfo
SetIIS = True
Set WebServiceObj = Nothing
Set WebServerObj = Nothing
Set WebServerRoot = Nothing
Set VDir = Nothing
Exit Function
ErrHandle:
MsgBox " 创建WEB站点失败，请从IIS管理器设置该站点的属性，或与开发商联系！", 48, "提示"
End Function

Public Function DelWeb(WebName As String) As Integer
On Error Resume Next
Set WebServerRoot = GetObject("IIS://LocalHost/W3SVC/1/Root")
For Each ExistVDir In WebServerRoot
        If LCase(ExistVDir.Name) = LCase(WebName) Then
               WebServerRoot.Delete "IIsWebVirtualDir", WebName
               Exit For
        End If
Next
Set ExistVDir = Nothing
Set WebServerRoot = Nothing

If err.Number <> 0 Then
   DelWeb = 1
End If

End Function



Public Function BuildTable(Mconn As ADODB.Connection) As Integer
Dim MCom As New ADODB.Command
Dim Fso As New FileSystemObject
Dim Mfod As Folder
Dim Mfile As File
Dim Mstr As String
Dim Txt As TextStream
On Error GoTo err
Set Mfod = Fso.GetFolder(App.Path & "\script")

For Each Mfile In Mfod.Files
    Set Txt = Fso.OpenTextFile(Mfile.Path)
    '获得需要创建的表的名称
    MCom.CommandText = Txt.ReadAll
    MCom.ActiveConnection = Mconn
    MCom.Execute
    Txt.Close
Next
Mstr = "CREATE VIEW UserGroup  AS  select distinct groupname From groupuser where groupname<>''"
Mconn.Execute Mstr, 64

Mstr = "CREATE VIEW UserName AS select * from groupuser where groupname=''"
Mconn.Execute Mstr, 64

Mstr = "create view treeview(username,treeno,limit) as select distinct groupuser.username,treebase.treeno,limit From treelimit, treebase, groupuser Where treelimit.TreeNo = treebase.TreeNo and treelimit.username=groupuser.username and treebase.dispstate=1 and substring(treelimit.limit,1,1)='1'"
Mconn.Execute Mstr, 64



Set Fso = Nothing
BuildTable = 1
Exit Function
err:
BuildTable = -1
Set Fso = Nothing
End Function


Public Function ConnDb() As Boolean
ConnDb = False
'判断Sql连接是否正确
If Pubsaconn.State = 1 Then
   Pubsaconn.Close
End If
Pubsaconnstring = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=bkbt919;Initial Catalog=" & Curdb & ";Data Source=" & Sevname & ";password=919bkbt"
On Error Resume Next
Pubsaconn.Open Pubsaconnstring
If err.Number <> 0 Then
   MsgBox "数据库连接出错!请重新设置", 64
   
   Exit Function
End If
On Error GoTo 0
ConnDb = True


End Function
Public Sub SetGride(GrdUser As MSHFlexGrid, GrdGroup As MSHFlexGrid)
Dim str As String
Dim i As Integer
On Error Resume Next
'============用户更新
GrdUser.Clear
GrdUser.Rows = 1
GrdUser.Cols = 1

str = "select distinct username,deparment_c,username_c,password,phoneNo from groupuser"
Set RstUser = Pubsaconn.Execute(str)

GrdUser.Redraw = False
    GrdUser.Redraw = False
    GrdUser.Cols = 4
    For i = 0 To 3
        GrdUser.ColWidth(i) = 2000
    Next
        
    GrdUser.TextMatrix(0, 0) = "用户名 (英文)"
    GrdUser.TextMatrix(0, 1) = "部门"
    GrdUser.TextMatrix(0, 2) = "用户名(中文)"
    GrdUser.TextMatrix(0, 3) = "内线电话"
    GrdUser.Rows = 1
    Do Until RstUser.EOF
        GrdUser.Rows = GrdUser.Rows + 1
        GrdUser.TextMatrix(GrdUser.Rows - 1, 0) = RstUser(0)
        GrdUser.TextMatrix(GrdUser.Rows - 1, 1) = RstUser(1)
        GrdUser.TextMatrix(GrdUser.Rows - 1, 2) = RstUser(2)
        GrdUser.TextMatrix(GrdUser.Rows - 1, 3) = RstUser(4)
        RstUser.MoveNext
    Loop
    GrdUser.Redraw = True
    GrdUser.FixedCols = 0
    If frmUserMain.GrdUser.Rows > 1 Then
        frmUserMain.GrdUser.FixedRows = 1
    End If
    RstUser.Close
    
    '======用户组情况
    str = "select distinct groupname from groupuser where groupname!=''"
    Set RstUser = Pubsaconn.Execute(str)
    GrdGroup.ColWidth(0) = 8055
    GrdGroup.TextMatrix(0, 0) = "组名"
    GrdGroup.Cols = 1
    GrdGroup.Rows = 1
    Do Until RstUser.EOF
        GrdGroup.Rows = GrdGroup.Rows + 1
        GrdGroup.TextMatrix(GrdGroup.Rows - 1, 0) = RstUser("groupname")
        RstUser.MoveNext
    Loop
    RstUser.Close
    If GrdGroup.Rows > 1 Then
        GrdGroup.FixedRows = 1
    End If
    
End Sub



Public Function CopyFile() As Integer
Dim Fso As New FileSystemObject
Dim SourPath As String
On Error Resume Next

SourPath = InstallPath
If Right(Aimpath, 1) = "\" Then
   Aimpath = Left(Aimpath, Len(Aimpath) - 1)
End If
Fso.CopyFolder SourPath, Aimpath, True
If err.Number <> 0 Then
   CopyFile = 1
Else
   CopyFile = 0
End If
Set Fso = Nothing
End Function

Public Function CheckSourPath() As Integer
Dim Fso As New FileSystemObject
Dim i As Integer
Dim Drivename As String
For i = 110 To 100 Step -1
    Drivename = Chr(i) & ":"
    If Fso.DriveExists(Drivename) Then
       If Fso.FolderExists(Drivename & "\" & RootPath) Then
           InstallPath = Drivename & "\" & RootPath
           
           CheckSourPath = 0
           Exit Function
       End If
   End If
Next i
CheckSourPath = 1
Set Fso = Nothing
End Function
'判断数据类型
Public Function GetDataType(Tbname As String, Fieldname As String) As String
Dim rst As New ADODB.Recordset
Dim sql As String
sql = "select 类型 from systemtable where 表名='" & Tbname & "' and 字段名='" & Fieldname & "'"
Set rst = PubMdbConn.Execute(sql)
If Not rst.EOF Then
   GetDataType = UCase(rst(0))
End If
rst.Close
Set rst = Nothing

End Function

'判断当前表是否需要带有扩展属性
Public Function GetTbE(Tbname As String) As Integer
On Error Resume Next
Dim rst As ADODB.Recordset
Dim sql As String
If Tbname = "" Then
    GetTbE = -1
    Exit Function
End If
sql = "select * from basetable where tablename='" & Tbname & "'"
Set rst = New ADODB.Recordset
Set rst = PubMdbConn.Execute(sql)
If rst.EOF Then
    GetTbE = 0
Else
    GetTbE = 1
End If
rst.Close
Set rst = Nothing
End Function

'获得站点的详细信息
Public Function GetWebinfo() As Integer
Dim rst As New ADODB.Recordset
Dim sql As String
Dim i As Integer
GetWebinfo = -1
sql = "select * from webset order by webid"
Set rst = PubMdbConn.Execute(sql)
Do While Not rst.EOF
    WebInfo(i, 0) = rst("webid")
    WebInfo(i, 1) = rst("webname")
    WebInfo(i, 2) = rst("sevname")
    WebInfo(i, 3) = rst("dbname")
    rst.MoveNext
    
    i = i + 1
Loop
If i > 0 Then
    GetWebinfo = i - 1
End If
    
Set rst = Nothing
End Function







'判断是否第一次安装
Public Function GetFirstInstall() As Boolean
ld = GetString(HKEY_LOCAL_MACHINE, "software\北科奔腾", "Initval")
If ld = "" Then
    GetFirstInstall = False
Else
    GetFirstInstall = True
End If
End Function


Public Function GetIniFilePath() As String
    
    Dim sSysPath As String * 255
    Dim lLength As Long
    Dim lRet As Long
    Dim sWinPath As String
    
    lLength = 255
    
    lRet = GetSystemDirectory(sSysPath, lLength)
    sSysPath = Mid(sSysPath, 1, InStr(4, sSysPath, "\"))
    sWinPath = sSysPath
    sWinPath = Trim(sWinPath)
    If lRet <> 0 Then
        GetIniFilePath = sWinPath & "\DBConfig.ini"
    Else
        GetIniFilePath = -1
    End If
    
End Function


' 写ini文件的数值
'参数 文件路径，段落，关键字，默认数值
Public Sub writeINI(sINIFile As String, sSection As String, sKey _
                As String, sValue As String)

    Dim n As Integer
    Dim sTemp As String
    
    sTemp = sValue
    For n = 1 To Len(sValue)
        If Mid$(sValue, n, 1) = vbCr Or Mid$(sValue, n, 1) = vbLf Then
            Mid$(sValue, n) = ""
        End If
    Next n
    
    n = WritePrivateProfileString(sSection, sKey, sTemp, sINIFile)

End Sub


Public Function CfgforMail(Sevname As String, dbName As String) As Boolean
Dim sINIPath As String
Dim sSetting As String
Dim Fso As Object
Set Fso = CreateObject("scripting.filesystemobject")
sINIPath = GetIniFilePath()
If Not Fso.FileExists(sINIPath) Then Fso.CreateTextFile (sINIPath)
sSetting = Trim("EMS")
writeINI sINIPath, sSetting, "ServerName", Sevname
writeINI sINIPath, sSetting, "DBName", dbName
writeINI sINIPath, sSetting, "UserName", "bkbt919"
writeINI sINIPath, sSetting, "PassWord", "919bkbt"
writeINI sINIPath, sSetting, "ConnectMethod", 1
Set Fso = Nothing


End Function