连接数据库方面
说用户名'sa'登录失败。该用户与可信SQL Server连接无关联。
Public conn As New ADODB.Connection '公用数据库连接
Dim xlapp As New Excel.Application
Public Sub main()
'打开数据连接字符串
'打开窗体frmain和frmlogin
conn.Open "Provider=SQLOLEDB.1;Password=zjtj;Persist Security Info=True;User ID=sa;Initial Catalog=CSJXC;Data Source=."
frmLogin.Show
End Sub
Public Function SetSql(strSql As String) As String
'定义不带返回的数据连接
Dim cmd As New ADODB.Command
On Error Resume Next
Set cmd.ActiveConnection = conn
cmd.CommandText = strSql
cmd.Execute
If Err Then
Exec_SqL = Err.Description
Exit Function
End If
On Error GoTo 0
SetSql = "OK"
End Function
Public Function GetSql(strSql As String) As ADODB.Recordset
'定义带返回记录级的数据连接
Dim rs As New ADODB.Recordset
With rs
.CursorLocation = adUseClient
If .State = 1 Then .Close
.Open strSql, conn, adOpenDynamic, adLockOptimistic
End With
Set GetSql = rs
End Function
Public Sub UpdateDDD(ddd As MSHFlexGrid, rs As ADODB.Recordset)
'以数据库记录集中地记录更新相应的显示列表
With rs
If .RecordCount > 0 Then
Dim i As Long
Dim ii As Long
If .RecordCount > 30 Then
ddd.Rows = .RecordCount + 1
End If
i = 1
Do Until .EOF
For ii = 0 To ddd.Cols - 1
ddd.TextMatrix(i, ii) = " " & Trim(.Fields(ii).Value)
Next
.MoveNext
i = i + 1
Loop
End If
End With
End Sub
Function ReturnText(strText As String, intLen As Long)
If Len(strText) > intLen Then
ReturnText = Mid(strText, 1, intLen) & "..."
Else
ReturnText = strText
End If
End Function
Function MoveFont(ddd As MSHFlexGrid, intRow As Long)
'当选中列表中的某行时,该列高亮度显示(如果改变行时,还原刚才的行为正常显示)
Dim i As Long
Dim ii As Long
For i = 1 To ddd.Rows - 1
If i <> intRow Then
ddd.Col = 0
ddd.Row = i
If ddd.CellForeColor <> &H0& Then
For ii = 0 To ddd.Cols - 1
ddd.Col = ii
ddd.CellForeColor = &H0&
Next
End If
Else
For ii = 0 To ddd.Cols - 1
ddd.Row = i
ddd.Col = ii
ddd.CellForeColor = &HFF0000
Next
End If
Next
ddd.Row = intRow
ddd.Col = ddd.MouseCol
End Function
Sub OutExcel(objDDD As MSHFlexGrid, strTitleCaption As String)
xlapp.Quit
Set xlapp = Nothing
Set xlapp = CreateObject("Excel.Application")
xlapp.Workbooks.Close
xlapp.Workbooks.Add
'-----------------------------------------------------变量区域
Dim arrTitle
arrTitle = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
Dim strTitle As String '标题
Dim i As Long
Dim ii As Long
'-----------------------------------------------------文字标头
With xlapp
.Range("A1", arrTitle(objDDD.Cols - 1) & "1").Select
With .Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
.Selection.Merge
.Rows("1:1").RowHeight = 27.75
strTitle = strTitleCaption
.ActiveCell.FormulaR1C1 = strTitle
With .ActiveCell.Characters(Start:=1, Length:=Len(strTitle)).Font
.Name = "Times New Roman"
.FontStyle = "加粗"
.Size = 16
End With
With .Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'-------------------------------------------------循环给列表复长度
For i = 0 To objDDD.Cols - 1
.Columns(arrTitle(i)).ColumnWidth = objDDD.ColWidth(i) / 100
Next
'-------------------------------------------------设置单元格的网格
.Range(arrTitle(0) & "2", arrTitle(objDDD.Cols - 1) & objDDD.Rows + 1).Select
.Selection.NumberFormatLocal = "@"
.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With .Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Dim strContent As String
Dim intStartRow As Long
intStartRow = 2
strContent = ""
For ii = 0 To objDDD.Cols - 1
If objDDD.MergeCol(ii) = True Then
For i = 0 To objDDD.Rows - 1
If Trim(strContent) = Trim(objDDD.TextMatrix(i, ii)) Then
.Range(arrTitle(ii) & intStartRow, arrTitle(ii) & i + 2).Select
With .Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
.Selection.Merge
.Range(arrTitle(ii) & intStartRow).Value = Trim(objDDD.TextMatrix(i, ii))
Else
intStartRow = i + 2
strContent = objDDD.TextMatrix(i, ii)
.Range(arrTitle(ii) & intStartRow).Value = Trim(objDDD.TextMatrix(i, ii))
End If
Next
Else
For i = 0 To objDDD.Rows - 1
.Range(arrTitle(ii) & i + 2).Value = Trim(objDDD.TextMatrix(i, ii))
Next
End If
Next
End With
xlapp.Visible = True
End Sub
