Excel を利用した印刷処理

  Command1_Click()



  
	If Combo1.Text = "" Then
		MsgBox ("コースを選択して下さい")
		Exit Sub
	End If

	Set fso = CreateObject("Scripting.FileSystemObject")
	fso.CopyFile App.Path & "\元フォーム.xls", App.Path & "\複写後フォーム.xls", True
	Set fso = Nothing
	
	' ----------------------------------------------------
	' Connection オブジェクト作成
	Set OpenDB = CreateObject("ADODB.Connection")
	
	' ----------------------------------------------------
	' 接続文字列作成
	strConnection = "Provider=SQLOLEDB;Data Source=サーバ名;"
	strConnection = strConnection & "Initial Catalog=DB名;"
	strConnection = strConnection & "User ID=sa;"
	strConnection = strConnection & "Password=;"

	' ----------------------------------------------------
	' DB 接続
	On Error Resume Next
	OpenDB.Open strConnection
	If Err.Number <> 0 Then
		Set OpenDB = Nothing
		MsgBox (Err.Description)
		Exit Sub
	End If
	On Error GoTo 0

	' ----------------------------------------------------
	' Recordset オブジェクト作成
	Set rs = CreateObject("ADODB.Recordset")
	
	' ----------------------------------------------------
	SqlQuery = "select * from テーブル名 " & " where コース = '" & Combo1.Text & "'"
	SqlQuery = SqlQuery & " order by コード"

	' ----------------------------------------------------
	' Recordset 取得
	rs.Open SqlQuery, OpenDB
	
	If rs.EOF Then
		rs.Close
		Set rs = Nothing
		OpenDB.Close
		Set OpenDB = Nothing
		MsgBox ("対象データが存在しませんでした")
		Exit Sub
	End If

	' ----------------------------------------------------
	' Excel アプリケーションオブジェクト作成
	Set ExcelApp = CreateObject("Excel.Application")
	
	' ----------------------------------------------------
	' Excel を表示させる
	ExcelApp.Visible = True
	
	' ベースBook を開く
	Set MyBook = ExcelApp.Workbooks.Open(App.Path & "\複写後フォーム.xls")
	
	' ベースSheet を選択
	MyBook.Sheets("Sheet1").Select
	
	' ベースSheet をCOPY
	MyBook.Sheets("Sheet1").Copy (MyBook.Sheets("Sheet1"))
	
	' 最初の名前で、Sheet 名を変更
	MyBook.ActiveSheet.Name = rs.Fields("氏名").Value

	' ブレイクキーの設定
	BreakMain = rs.Fields("コード").Value
	
	' 初回フラグ
	bFirst = True

	' 初期明細行位置
	nRow = 10

	Do While Not rs.EOF

		Me.Refresh
		
		If bFirst Then
			bFirst = False
			
			' タイトル部分のセット
			MyBook.ActiveSheet.Cells(4, 3).Value = rs.Fields("コード").Value
			MyBook.ActiveSheet.Cells(6, 3).Value = rs.Fields("氏名").Value
		
		Else
			' ブレイク処理
			If BreakMain <> rs.Fields("コード").Value Then
				' 新しいブックの作成
				MyBook.Sheets("Sheet1").Select
				MyBook.Sheets("Sheet1").Copy (MyBook.Sheets("Sheet1"))
				MyBook.ActiveSheet.Name = rs.Fields("氏名").Value
				
				' タイトル部分のセット
				MyBook.ActiveSheet.Cells(4, 3).Value = rs.Fields("コード").Value
				MyBook.ActiveSheet.Cells(6, 3).Value = rs.Fields("氏名").Value
				
				' 初期明細行位置
				nRow = 10
			End If
			
		End If
		
		' 明細のセット
		MyBook.ActiveSheet.Cells(nRow, 2).Value = rs.Fields("名称").Value
		nRow = nRow + 1
		
		' ブレイクキーの保存
		BreakMain = rs.Fields("コード").Value
		
		' 次データの読込み
		rs.MoveNext

	Loop

	rs.Close
	Set rs = Nothing
	OpenDB.Close
	Set OpenDB = Nothing
  










  infoboard   管理者用   
このエントリーをはてなブックマークに追加





フリーフォントWEBサービス
SQLの窓WEBサービス

SQLの窓フリーソフト

素材

一般WEBツールリンク

SQLの窓

フリーソフト

JSライブラリ