linksql.frm

金蝶财务软件主控台子功能管理,用于删除发布错误的BOS单据

VERSION 5.00
Begin VB.Form LinkSql 
   BackColor       =   &H00FFFFFF&
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "连接SQL服务器"
   ClientHeight    =   5250
   ClientLeft      =   2760
   ClientTop       =   3750
   ClientWidth     =   5655
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5250
   ScaleWidth      =   5655
   ShowInTaskbar   =   0   'False
   Begin VB.ComboBox Combo2 
      Height          =   300
      Left            =   960
      Style           =   2  'Dropdown List
      TabIndex        =   12
      Top             =   3735
      Width           =   4080
   End
   Begin VB.ComboBox Combo1 
      Appearance      =   0  'Flat
      Height          =   300
      Left            =   1395
      TabIndex        =   9
      Text            =   "."
      Top             =   225
      Width           =   2775
   End
   Begin VB.Frame Frame1 
      BackColor       =   &H80000009&
      Caption         =   "登录"
      Height          =   1485
      Left            =   840
      TabIndex        =   4
      Top             =   1920
      Width           =   4515
      Begin VB.TextBox Text1 
         Height          =   315
         Left            =   1260
         TabIndex        =   6
         Text            =   "sa"
         Top             =   435
         Width           =   2775
      End
      Begin VB.TextBox Text2 
         Height          =   315
         IMEMode         =   3  'DISABLE
         Left            =   1260
         PasswordChar    =   "*"
         TabIndex        =   5
         Top             =   825
         Width           =   2775
      End
      Begin VB.Label Label2 
         BackStyle       =   0  'Transparent
         Caption         =   "登录名"
         Height          =   255
         Left            =   540
         TabIndex        =   8
         Top             =   480
         Width           =   615
      End
      Begin VB.Label Label3 
         BackStyle       =   0  'Transparent
         Caption         =   "密码"
         Height          =   255
         Left            =   750
         TabIndex        =   7
         Top             =   870
         Width           =   375
      End
   End
   Begin VB.OptionButton Option2 
      BackColor       =   &H80000009&
      Caption         =   "SQL Server身份验证"
      Height          =   345
      Left            =   300
      TabIndex        =   3
      Top             =   1515
      Width           =   2850
   End
   Begin VB.OptionButton Option1 
      BackColor       =   &H80000009&
      Caption         =   "Windows身份验证"
      Height          =   360
      Left            =   300
      TabIndex        =   2
      Top             =   945
      Value           =   -1  'True
      Width           =   2280
   End
   Begin VB.CommandButton CancelButton 
      BackColor       =   &H00FFC0FF&
      Caption         =   "取消"
      Height          =   375
      Left            =   3600
      Style           =   1  'Graphical
      TabIndex        =   1
      Top             =   4695
      Width           =   1215
   End
   Begin VB.CommandButton OKButton 
      BackColor       =   &H00FFC0FF&
      Caption         =   "确定"
      Height          =   375
      Left            =   960
      Style           =   1  'Graphical
      TabIndex        =   0
      Top             =   4695
      Width           =   1215
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "K3数据库"
      Height          =   180
      Left            =   150
      TabIndex        =   11
      Top             =   3780
      Width           =   720
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "选择服务器"
      Height          =   255
      Left            =   345
      TabIndex        =   10
      Top             =   285
      Width           =   975
   End
End
Attribute VB_Name = "LinkSql"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Public m_b As Boolean

Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) As Long
Private Declare Function WNetEnumResource Lib "mpr.dll" Alias "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (lpTo As Any, lpFrom As Any, ByVal lLen As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long

Private Const RESOURCE_GLOBALNET As Long = &H2&  ' 枚举所有资源

'  网络资源类型常数
Private Const RESOURCEDISPLAYTYPE_DIRECTORY& = &H9
Private Const RESOURCEDISPLAYTYPE_DOMAIN& = &H1
Private Const RESOURCEDISPLAYTYPE_FILE& = &H4
Private Const RESOURCEDISPLAYTYPE_GENERIC& = &H0
Private Const RESOURCEDISPLAYTYPE_GROUP& = &H5
Private Const RESOURCEDISPLAYTYPE_NETWORK& = &H6
Private Const RESOURCEDISPLAYTYPE_ROOT& = &H7
Private Const RESOURCEDISPLAYTYPE_SERVER& = &H2
Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3
Private Const RESOURCEDISPLAYTYPE_SHAREADMIN& = &H8
Private Const RESOURCETYPE_ANY As Long = &H0&
Private Const RESOURCETYPE_DISK As Long = &H1&
Private Const RESOURCETYPE_PRINT As Long = &H2&
Private Const RESOURCETYPE_UNKNOWN As Long = &HFFFF&
Private Const RESOURCEUSAGE_ALL As Long = &H0&
Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&
Private Const RESOURCEUSAGE_CONTAINER As Long = &H2&
Private Const RESOURCEUSAGE_RESERVED As Long = &H80000000

Private Const NO_ERROR = 0
Private Const ERROR_MORE_DATA = 234
Private Const RESOURCE_ENUM_ALL As Long = &HFFFF

'   枚举信息数据类型
Private Type NETRESOURCE
    dwScope As Long        '  枚举的范围
    dwType As Long         '  枚举的类型
    dwDisplayType As Long  '  资源的类型
    dwUsage As Long        '  枚举的用法
    sLocalName As String   '  由本地系统引用的资源名称
    sRemoteName As String  '  资源的网络名
    sComment As String     '  由网络供应商设置
    sProvider As String    '  网络供应商的名字
End Type

'  自定义类型存放枚举信息
Private Type NETRESOURCE_BUF
    dwScope As Long        '  枚举的范围
    dwType As Long         '  枚举的类型
    dwDisplayType As Long  '  资源的类型
    dwUsage As Long        '  枚举的用法
    pLocalName As Long     '  由本地系统引用的资源名称
    pRemoteName As Long    '  资源的网络名
    pComment As Long       '  由网络供应商设置
    pProvider As Long      '  网络供应商的名字
End Type

'   用于获得网上邻居计算机名称的子程序
Private Sub GetNeighbor()
Const MAX_RESOURCES = 256
Const NOT_A_CONTAINER = -1

Dim bFirstTime As Boolean
Dim lReturn As Long
Dim hEnum As Long
Dim lCount As Long
Dim lMin As Long
Dim lLength As Long
Dim l As Long
Dim lBufferSize As Long
Dim lLastIndex As Long
Dim uNetApi(0 To MAX_RESOURCES) As NETRESOURCE_BUF
Dim uNet() As NETRESOURCE

bFirstTime = True

Do
    If bFirstTime Then
        '  启动对顶级网络资源进行枚举的过程,并返回枚举资源所用的句柄
        lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, hEnum)
        bFirstTime = False
    Else
        '  如果uNet(lLastIndex)资源包含了可以枚举的额外资源,并返回枚举资源所用的句柄
        If uNet(lLastIndex).dwUsage And RESOURCEUSAGE_CONTAINER Then
            '  启动对包含于指定资源内的资源的枚举
            lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, uNet(lLastIndex), hEnum)
        Else '否则
            lReturn = NOT_A_CONTAINER
            hEnum = 0
        End If
        '  下一个资源
        lLastIndex = lLastIndex + 1
    End If
    
    If lReturn = NO_ERROR Then  '如果返回值表示成功
        lCount = RESOURCE_ENUM_ALL
        Do
            '  设置缓冲区大小
            lBufferSize = UBound(uNetApi) * Len(uNetApi(0)) / 2
            '  应用上面WNetOpenEnum返回的句柄枚举网络资源,并将枚举信息装载到uNetApi缓冲区
            lReturn = WNetEnumResource(hEnum, lCount, uNetApi(0), lBufferSize)
            If lCount > 0 Then
                '  为动态数组变量重新分配存储空间
                ReDim Preserve uNet(0 To lMin + lCount - 1) As NETRESOURCE
                For l = 0 To lCount - 1
                    '将枚举信息赋值给 uNet
                    uNet(lMin + l).dwScope = uNetApi(l).dwScope
                    uNet(lMin + l).dwType = uNetApi(l).dwType
                    uNet(lMin + l).dwDisplayType = uNetApi(l).dwDisplayType
                    uNet(lMin + l).dwUsage = uNetApi(l).dwUsage
                    
                    '  对于以下的值通过内存复制的方式赋值
                    If uNetApi(l).pLocalName Then
                        lLength = lstrlen(uNetApi(l).pLocalName)
                        uNet(lMin + l).sLocalName = Space$(lLength)
                        CopyMem ByVal uNet(lMin + l).sLocalName, ByVal uNetApi(l).pLocalName, lLength
                    End If
                    
                    If uNetApi(l).pRemoteName Then
                        lLength = lstrlen(uNetApi(l).pRemoteName)
                        uNet(lMin + l).sRemoteName = Space$(lLength)
                        CopyMem ByVal uNet(lMin + l).sRemoteName, ByVal uNetApi(l).pRemoteName, lLength
                    End If
                    
                    If uNetApi(l).pComment Then
                        lLength = lstrlen(uNetApi(l).pComment)
                        uNet(lMin + l).sComment = Space$(lLength)
                        CopyMem ByVal uNet(lMin + l).sComment, ByVal uNetApi(l).pComment, lLength
                    End If
                    
                    If uNetApi(l).pProvider Then
                        lLength = lstrlen(uNetApi(l).pProvider)
                        uNet(lMin + l).sProvider = Space$(lLength)
                        CopyMem ByVal uNet(lMin + l).sProvider, ByVal uNetApi(l).pProvider, lLength
                    End If
                Next l
            End If
            lMin = lMin + lCount
        Loop While lReturn = ERROR_MORE_DATA
    End If
    
    If hEnum Then
    '  结束枚举操作
    l = WNetCloseEnum(hEnum)
    End If
Loop While lLastIndex < lMin

If UBound(uNet) > 0 Then
    For l = 0 To UBound(uNet)
       '  判断资源类型,并将网上邻居显示出来
       If uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SERVER Then
            Combo1.AddItem Right(uNet(l).sRemoteName, Len(uNet(l).sRemoteName) - 2)
       End If
    Next l
End If
End Sub

Private Sub CancelButton_Click()
Unload Me
End Sub

Private Sub Combo2_DropDown()

If Option1.Value = True Then
    g_ConnStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Server=" + Trim(Combo1.Text) + ";Initial Catalog=master"
    Text1.Text = ""
    Text2.Text = ""
Else
    g_ConnStr = "Provider=SQLOLEDB.1;Persist Security Info=True;Server=" + Trim(Combo1.Text) + ";User ID=" + Trim(Text1.Text) + ";PWD=" + Trim(Text2.Text) + ";Initial Catalog=master"
End If
On Error Resume Next
Err.Clear
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
con.Open g_ConnStr

If Err.Number <> 0 Then
   MsgBox "无法联接SQL，请检查SQL用户名和密码是否正确或者是联接方式？", , Me.Caption
   con.Close
   Set con = Nothing
   Exit Sub
End If
Set rs = con.Execute("select  name from sysdatabases")
Do While rs.EOF = False
    Combo2.AddItem rs!Name
    rs.MoveNext
Loop
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
End Sub

Private Sub Form_Load()
   'Call GetNeighbor

   Combo1.Text = "."
   Text1.Text = "sa"
   Text2.Text = ""
   m_b = False
   
End Sub

Private Sub OKButton_Click()
If Combo2.Text = "" Then
    MsgBox "没有数据库!", , Me.Caption
    Exit Sub
End If
g_ConnStr = Replace(g_ConnStr, "master", Combo2.Text)

Dim con As New ADODB.Connection
On Error Resume Next
Err.Clear
con.Open g_ConnStr
If Err.Number <> 0 Then
   MsgBox "无法联接SQL，请检查SQL用户名和密码是否正确或者是联接方式，及数据库是否正确？", , Me.Caption
   con.Close
   Set con = Nothing
   Exit Sub
End If
con.Execute "select top 1 * from t_tableDescription"
If Err.Number <> 0 Then
   MsgBox "该数据库不是K3帐套数据库？", , Me.Caption
   con.Close
   Set con = Nothing
   Exit Sub
End If
On Error GoTo 0
con.Close
Set con = Nothing

m_b = True
Unload Me
End Sub