waiwentushu.dob

VB的图书馆管理系统

    Dim DataArray() As Variant
    Dim i, j, Num As Integer
    
    Screen.MousePointer = vbHourglass
    
    'Start a new workbook in Excel
    Set oExcel = CreateObject("Excel.Application")
    Set oBook = oExcel.Workbooks.Add
    
    'Create an array
    Num = datPrimaryRS.Recordset.RecordCount
    If Num = 0 Then
      MsgBox "发排数据为空。", vbInformation
      Exit Sub
    End If
    ReDim DataArray(1 To Num, 1 To 10) As Variant
    
    datPrimaryRS.Recordset.MoveFirst
    For i = 1 To Num
        For j = 1 To 10
            DataArray(i, j) = datPrimaryRS.Recordset.Fields(j - 1).Value
        Next
        datPrimaryRS.Recordset.MoveNext
    Next
    datPrimaryRS.Recordset.MoveFirst
    
    'Add headers to the worksheet on row 1
    Set oSheet = oBook.Worksheets(1)
    oSheet.Range("A1:J1").Select
    With oExcel.Selection
        .HorizontalAlignment = -4108
        .VerticalAlignment = -4108
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    oSheet.Range("A1").Value = Format(Now(), "yyyy") & "年外文图书总帐"
    oSheet.Range("A2").Value = "总号"
    oSheet.Range("B2").Value = "分类"
    oSheet.Range("C2").Value = "书名"
    oSheet.Range("D2").Value = "作者"
    oSheet.Range("E2").Value = "出版单位"
    oSheet.Range("F2").Value = "单价"
    oSheet.Range("G2").Value = "册数"
    oSheet.Range("H2").Value = "出版日期"
    oSheet.Range("I2").Value = "登记日期"
    oSheet.Range("J2").Value = "备注"
    oSheet.Range("A2:J2").Select
    With oExcel.Selection
        .HorizontalAlignment = -4108
        .VerticalAlignment = -4108
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
    End With
    
    'Transfer the array to the worksheet starting at cell A2
    oSheet.Range("A3").Resize(Num, 10).Value = DataArray
    
    oSheet.Range("A2:J" & CStr(Num + 2)).Select
    oExcel.Selection.Borders(5).LineStyle = -4142
    oExcel.Selection.Borders(6).LineStyle = -4142
    With oExcel.Selection.Borders(7)
        .LineStyle = 1
        .Weight = 3
        .ColorIndex = -4105
    End With
    With oExcel.Selection.Borders(8)
        .LineStyle = 1
        .Weight = 3
        .ColorIndex = -4105
    End With
    With oExcel.Selection.Borders(9)
        .LineStyle = 1
        .Weight = 3
        .ColorIndex = -4105
    End With
    With oExcel.Selection.Borders(10)
        .LineStyle = 1
        .Weight = 3
        .ColorIndex = -4105
    End With
    With oExcel.Selection.Borders(11)
        .LineStyle = 1
        .Weight = 2
        .ColorIndex = -4105
    End With
    With oExcel.Selection.Borders(12)
        .LineStyle = 1
        .Weight = 2
        .ColorIndex = -4105
    End With
    
    oSheet.Range("E" & CStr(Num + 3)).Value = "合计"
    oSheet.Range("F" & CStr(Num + 3)).Formula = "=SUM(F3:F" & CStr(Num + 2) & ")"
    oSheet.Range("G" & CStr(Num + 3)).Formula = "=SUM(G3:G" & CStr(Num + 2) & ")"

    
    oSheet.Columns("A:A").EntireColumn.AutoFit
    oSheet.Columns("B:B").EntireColumn.AutoFit
    oSheet.Columns("C:C").EntireColumn.AutoFit
    oSheet.Columns("D:D").EntireColumn.AutoFit
    oSheet.Columns("E:E").EntireColumn.AutoFit
    oSheet.Columns("F:F").EntireColumn.AutoFit
    oSheet.Columns("G:G").EntireColumn.AutoFit
    oSheet.Columns("H:H").EntireColumn.AutoFit
    oSheet.Columns("I:I").EntireColumn.AutoFit
    oSheet.Columns("J:J").EntireColumn.AutoFit
    
    
    With oSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    oSheet.PageSetup.PrintArea = ""
    With oSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = oExcel.InchesToPoints(0.75)
        .RightMargin = oExcel.InchesToPoints(0.75)
        .TopMargin = oExcel.InchesToPoints(1)
        .BottomMargin = oExcel.InchesToPoints(1)
        .HeaderMargin = oExcel.InchesToPoints(0.5)
        .FooterMargin = oExcel.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = -4142
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = 2
        .Draft = False
        .PaperSize = 12
        .FirstPageNumber = -4105
        .Order = 1
        .BlackAndWhite = False
        .Zoom = 100
    End With
       
    oSheet.Range("A1").Select

    oExcel.Visible = True
    
    Screen.MousePointer = vbDefault
    
    Set oExcel = Nothing
    Set oBook = Nothing
    Set oSheet = Nothing
End Sub

Private Sub cmdPrint1_Click()
    Dim strSQL As String
    Dim oWrd As Object
    
    Set oWrd = CreateObject("Word.Application")
    oWrd.Visible = True
    oWrd.Activate
    oWrd.Documents.Add

    With oWrd.ActiveDocument.PageSetup
        .TopMargin = 24
        .BottomMargin = 72
        .LeftMargin = 50
        .RightMargin = 361
        .PageWidth = 595.3
        .PageHeight = 841.9
    End With
    
    With oWrd.Selection
      
      With .ParagraphFormat
            .Alignment = 3
            .LineSpacingRule = 1
            .SpaceBefore = 0
            .SpaceAfter = 0
      End With
      
      .Font.Name = "宋体"
      .Font.Bold = True
      .Font.Size = 12
      .TypeText "图" & Format(txtFields(1).Text, "00000")
      .TypeParagraph
      
      .Font.Size = 10.5
      .Font.Bold = True
      
      With .ParagraphFormat
            .Alignment = 3
            .LineSpacingRule = 0
            .SpaceBefore = 0
            .SpaceAfter = 0
      End With

      .TypeText txtFields(3).Text
      .TypeParagraph
      .TypeText txtFields(0).Text
      .TypeParagraph
      
      .HomeKey unit:=6

    End With

    Set oWrd = Nothing
    

End Sub

Private Sub datPrimaryRS_Error(ByVal ErrorNumber As Long, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, fCancelDisplay As Boolean)
  '错误处理程序代码置于此处
  '想要忽略错误，注释掉下一行
  '想要捕获它们，在此添加代码以处理它们
  MsgBox "Data error event hit err:" & Description
End Sub

Private Sub cmdAdd_Click()
  On Error GoTo AddErr
  datPrimaryRS.Recordset.AddNew

  Exit Sub
AddErr:
  MsgBox Err.Description
End Sub

Private Sub cmdDelete_Click()
'  On Error GoTo DeleteErr
'  With datPrimaryRS.Recordset
'    .Delete
'    .MoveNext
'    If .EOF Then .MoveLast
'  End With
'  Exit Sub
'DeleteErr:
'  MsgBox Err.Description

  Dim lgNum As Long
  
  On Error GoTo DeleteErr
    Dim nYN As Byte
    
     nYN = MsgBox("您正准备删除当前记录。" & Chr(13) & Chr(13) & _
        "假如您单击“是”，您将不能撤消这个删除操作。" & Chr(13) & _
        "您确认删除这条记录吗?", vbExclamation + vbYesNo)
    
    If nYN = vbYes Then
      
      lgNum = datPrimaryRS.Recordset.AbsolutePosition
    
      cn.Execute " delete from 外文图书 where 图书id =" & txtFields(1).Text
      
      datPrimaryRS.Refresh
      datPrimaryRS.Recordset.AbsolutePosition = lgNum
      If datPrimaryRS.Recordset.EOF Then datPrimaryRS.Recordset.MoveLast
      
    End If
    
  Exit Sub
DeleteErr:
  MsgBox Err.Description


End Sub

Private Sub cmdRefresh_Click()
  '只有多用户应用程序需要
  On Error GoTo RefreshErr
  datPrimaryRS.Refresh
  Exit Sub
RefreshErr:
  MsgBox Err.Description
End Sub

Private Sub cmdUpdate_Click()
  On Error GoTo UpdateErr

  datPrimaryRS.Recordset.UpdateBatch adAffectAll
  Exit Sub
UpdateErr:
  MsgBox Err.Description
End Sub


Private Sub UserDocument_Initialize()
'    With datPrimaryRS
'        .ConnectionString = pConn
'        .RecordSource = "select 图书ID, 分类ID, 书名, 作者, 出版单位, 单价, 册数, 出版日期, 登记日期, 备注, 页数, 译名, 文种id from 外文图书 ORDER BY 图书ID;"
'        .Refresh
'    End With
    
    
    Dim strSQL As String
    
    cn.Open pConn
    
    
    strSQL = "select 图书ID, 分类, 书名, 作者, 出版单位, 单价, 册数, 出版日期, 登记日期, 备注, 页数, 译名, 外文图书.分类ID, 文种id " & _
      "FROM 外文图书 INNER JOIN 图书分类 ON 外文图书.分类ID = 图书分类.分类ID " & _
      " ORDER BY 图书ID;"
    
    With rs
        .ActiveConnection = cn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockOptimistic
        .Open strSQL
    End With
    
    Set datPrimaryRS.Recordset = rs
    
    With Adodc1
        .ConnectionString = pConn
        .RecordSource = "图书分类"
        .Refresh
    End With

    With Adodc2
        .ConnectionString = pConn
        .RecordSource = "文种"
        .Refresh
    End With
    
    With DataCombo1
        Set .DataSource = datPrimaryRS
        .DataField = "分类id"
        Set .RowSource = Adodc1
        .ListField = "分类"
        .BoundColumn = "分类id"
    End With

End Sub

Private Sub UserDocument_Show()
'    datPrimaryRS.Refresh
End Sub

Private Sub UserDocument_Terminate()
    rs.Close
    cn.Close
    
End Sub