Private Sub outExceldata(ByVal xlFilePath As String, ByVal SheetNum As Integer, _
ByVal dtTableSheet As DataTable, ByVal dtTableWB出力 As DataTable) ''プロジェクト→参照の追加→COM→Microsoft Excel *.* ObjectLibrary を参照して下さい '================== 起動時の処理 =================== Dim xlApp As Object = CreateObject("Excel.Application") Dim xlBooks As Object = xlApp.WorkbooksDim xlBook As Object = xlBooks.Open(xlFilePath)
Dim xlSheets As Object = xlBook.Worksheets Dim xlSheet As Object = xlSheets.Item(1)Dim xlSheetMoto As Object = Nothing
Dim xlSheetIchi As Object = Nothing Dim xlSheetColor As Object = Nothing Dim xlRange As Object = Nothing Dim xlRangeColor As Object = Nothing Dim xlHoge As Object = NothingDim dtRow() As DataRow
Dim intArgb0 As Integer = 0
Dim intArgb1 As Integer = 0 Dim intArgb2 As Integer = 0 Dim strBackColorArgb As String = String.EmptyDim strExcelName As String = "WhiteBoard" & CDate(Utility.GetDBTime).ToString("yyyyMMdd")
Try
xlApp.Visible = False 'Excelを表示(必ずとも表示しなくてもよい)
For intLoop = 1 To SheetNum - 1 Step 1
'シートを指定位置にコピーする
xlSheetMoto = DirectCast(xlSheets.Item(1), Excel.Worksheet) xlSheetIchi = DirectCast(xlSheets.Item(intLoop), Excel.Worksheet) xlSheetMoto.Copy(, xlSheetIchi)Next
'For intLoop = 1 To SheetNum - 1 Step 1
' xlSheets.Copy(Before:=xlSheets.Item(intLoop)) ' xlSheets.Item(intLoop).Name = dtTableSheet.Rows(intLoop - 1).Item(1)' ''シートのコピー
' 'xlSheet = xlSheets.Item(intLoop) 'シートの選択 ' 'xlSheet.Copy(Before:=xlBook.Worksheets(1)) 'シートのコピー ' 'xlSheet = xlSheets.Item(1) '再度シートを選択 ' 'xlSheet.Name = intLoop 'シートに名前を付ける 'NextFor intLoop = 1 To SheetNum Step 1
xlSheetColor = xlSheets.Item(intLoop) xlSheetColor.Select() xlRange = xlSheetColor.Range("A1") xlRange.Select()strBackColorArgb = dtTableSheet.Rows(intLoop - 1).Item(2).ToString
intArgb0 = Convert.ToInt32(strBackColorArgb.Substring(0, 2), 16)
intArgb1 = Convert.ToInt32(strBackColorArgb.Substring(2, 2), 16) intArgb2 = Convert.ToInt32(strBackColorArgb.Substring(4, 2), 16)Dim objColor As Color
objColor = Utility.Fn_Color_DB_ColorRGB(dtTableSheet.Rows(intLoop - 1).Item(2).ToString)
xlRangeColor = xlSheetColor.Range("A1:G1")
xlRangeColor.Select() xlHoge = xlRangeColor.Interior xlHoge.Color = RGB(objColor.R, objColor.G, objColor.B)'xlRangeColor.Interior.Color = RGB(objColor.R, objColor.G, objColor.B)
xlSheetColor.Name = dtTableSheet.Rows(intLoop - 1).Item(1)
dtRow = dtTableWB出力.Select(" 依頼先 = '" & dtTableSheet.Rows(intLoop - 1).Item(0) & "' ")
For i = 0 To dtRow.Length - 1 Step 1
For j = 0 To dtTableWB出力.Columns.Count - 2 Step 1
xlSheets.Item(intLoop).Cells(i + 2, j + 1) = dtRow(i).Item(j)
Next
Next
Next
''カーソル
xlSheets.Item(1).select()If System.IO.File.Exists(xlFilePath.Substring(0, xlFilePath.Length - 1) & "s") = True Then
Try
System.IO.File.Delete(xlFilePath.Substring(0, xlFilePath.Length - 1) & "s")Catch ex As Exception
MessageBox.Show("Opening", "Error", MessageBoxButtons.OK, MessageBoxIcon.Warning) Exit SubEnd Try
End If
'ファイルの保存
' SaveFileDialog の新しいインスタンスを生成する (デザイナから追加している場合は必要ない) Dim SaveFileDialog1 As New SaveFileDialog() Dim res As DialogResult' ダイアログのタイトルを設定する
SaveFileDialog1.Title = "名前を付けて保存"' 初期表示するディレクトリを設定する
If gstrSavePath <> String.Empty Then SaveFileDialog1.InitialDirectory = gstrSavePath End If' 初期表示するファイル名を設定する
SaveFileDialog1.FileName = strExcelName' ファイルのフィルタを設定する
SaveFileDialog1.Filter = "Microsoft Office Excel ブック (*.xls)|*.xls;*.xlw|テキスト ファイル|*.txt;*.log|すべてのファイル|*.*"' ファイルの種類 の初期設定を 2 番目に設定する (初期値 1)
'SaveFileDialog1.FilterIndex = 1' ダイアログボックスを閉じる前に現在のディレクトリを復元する (初期値 False)
SaveFileDialog1.RestoreDirectory = True' [ヘルプ] ボタンを表示する (初期値 False)
'SaveFileDialog1.ShowHelp = True' 存在しないファイルを指定した場合は、
' 新しく作成するかどうかの問い合わせを表示する (初期値 False) 'SaveFileDialog1.CreatePrompt = False' 存在しているファイルを指定した場合は、
' 上書きするかどうかの問い合わせを表示する (初期値 True) SaveFileDialog1.OverwritePrompt = False' 存在しないファイル名を指定した場合は警告を表示する (初期値 False)
'SaveFileDialog1.CheckFileExists = True' 存在しないパスを指定した場合は警告を表示する (初期値 True)
'SaveFileDialog1.CheckPathExists = True' 拡張子を指定しない場合は自動的に拡張子を付加する (初期値 True)
SaveFileDialog1.AddExtension = True' 有効な Win32 ファイル名だけを受け入れるようにする (初期値 True)
'SaveFileDialog1.ValidateNames = Trueres = SaveFileDialog1.ShowDialog()
' ダイアログを表示し、戻り値が [OK] の場合は、選択したファイルを表示する
If res = Windows.Forms.DialogResult.OK ThenxlApp.DisplayAlerts = False
'oBook.SaveAs(saveFileDialog1.FileName, Excel.XlFileFormat.xlExcel8)
If CType(xlApp.Version.ToString, Decimal) < 12 Then xlBook.SaveAs(SaveFileDialog1.FileName) Else xlBook.SaveAs(SaveFileDialog1.FileName, 56) End IfxlBook.Close()
xlApp.DisplayAlerts = True
gstrSavePath = SaveFileDialog1.FileName()
gstrSavePath = Mid(gstrSavePath, 1, InStrRev(gstrSavePath, "\"))'成功メッセージを呼び出し
CommonMsg.showMsg(Me.Tag.ToString, ENU_MSGID.Finish, "WB出力") Else xlApp.DisplayAlerts = False xlBook.Close() xlApp.DisplayAlerts = True End If' 不要になった時点で破棄する (正しくは オブジェクトの破棄を保証する を参照)
SaveFileDialog1.Dispose()'================== 終了処理 =====================
Try 'COMオブジェクトの解放 COM_MRComObject(xlHoge) COM_MRComObject(xlRangeColor) COM_MRComObject(xlRange) COM_MRComObject(xlSheetColor) COM_MRComObject(xlSheetMoto) COM_MRComObject(xlSheetIchi) COM_MRComObject(xlSheet) 'xlSheet の解放 COM_MRComObject(xlSheets) 'xlSheets の解放 COM_MRComObject(xlBook) 'xlBook の解放 xlBooks.Close() COM_MRComObject(xlBooks) 'xlBooks の解放 xlApp.Quit() COM_MRComObject(xlApp) 'xlApp を解放 Catch ex As ExceptionEnd Try
Catch ex As Exception
'異常処理 EXHelper.ProcessEx(ex, Me.Tag.ToString)Finally
'デフォルトのカーソル
Me.Cursor = Cursors.Default'================== 終了処理 =====================
'COMオブジェクトの解放
COM_MRComObject(xlHoge) COM_MRComObject(xlRangeColor) COM_MRComObject(xlRange) COM_MRComObject(xlSheetColor) COM_MRComObject(xlSheetMoto) COM_MRComObject(xlSheetIchi) COM_MRComObject(xlSheet) 'xlSheet の解放 COM_MRComObject(xlSheets) 'xlSheets の解放 COM_MRComObject(xlBook) 'xlBook の解放 COM_MRComObject(xlBooks) 'xlBooks の解放 COM_MRComObject(xlApp) 'xlApp を解放GC.Collect()
xlHoge = Nothing
xlRangeColor = Nothing xlRange = Nothing xlSheetColor = NothingxlSheetMoto = Nothing
xlSheetIchi = Nothing xlSheet = Nothing xlSheets = Nothing xlBook = Nothing xlBooks = Nothing xlApp = Nothing '------------------------------------------------------------------------- 'テスト中は、下記コードを 上記 Excel 終了後に実施するようにして下さい。 'この方法だと強制的にガベージ コレクションをしなくても 'キチンと終了しています。(プロセスが終了している・タスクマネージャに表示していない) '[Ctrl]+[Alt]+[Del]キーを押してWindows タスクマネージャ→プロセス に 'Excel.EXE が残っていないかを確認して下さい。 '★☆★☆★☆★☆★☆ Debug 中は下記を実行して確認しながら進めて下さい ★☆★☆★☆★☆★☆ 'Dim st As Integer = System.Environment.TickCount 'Do While System.Environment.TickCount - st < 5000 ' Application.DoEvents() ' System.Threading.Thread.Sleep(500) ' If Process.GetProcessesByName("Excel").Length = 0 Then ' MessageBox.Show("Excel.EXE は解放されました。") ' Exit Do ' End If 'Loop 'If Process.GetProcessesByName("Excel").Length >= 1 Then ' MessageBox.Show("まだ Excel.EXE が起動しています。") ' '一度メッセージボックスを表示すると解放されるようなので再度確認 ' If Process.GetProcessesByName("Excel").Length = 0 Then ' MessageBox.Show("Excel.EXE は解放されました。") ' End If 'End If '-------------------------------------------------------------------------- End Try End Sub'*-------------------------------------------------------------------*
' 【機 能】Excelのシートコピー ' 【引 き 数】xlBook : Excelワークブック ' SheetNoMoto : コピー元シート番号 ' SheetNoIchi : コピー位置のシート番号 ' BeforeOrAfter : コピー位置の前(True)or後ろ(False) ' 【返 り 値】- '*-------------------------------------------------------------------* Public Sub CE_ExcelSheetCopy(ByVal xlBook As Excel.Workbook, ByVal SheetNoMoto As Integer, ByVal SheetNoIchi As Integer, ByVal BeforeOrAfter As Boolean) Dim xlSheets As Excel.Sheets Dim xlSheetMoto As Excel.Worksheet Dim xlSheetIchi As Excel.WorksheetTry
'シートを指定位置にコピーする xlSheets = xlBook.Worksheets xlSheetMoto = DirectCast(xlSheets.Item(SheetNoMoto), Excel.Worksheet) xlSheetIchi = DirectCast(xlSheets.Item(SheetNoIchi), Excel.Worksheet) If BeforeOrAfter = True Then xlSheetMoto.Copy(xlSheetIchi) Else xlSheetMoto.Copy(, xlSheetIchi) End If'COMオブジェクトの解放
COM_MRComObject(xlSheetMoto) COM_MRComObject(xlSheetIchi) COM_MRComObject(xlSheets)Catch ex As Exception
MessageBox.Show(ex.Message, "Err", MessageBoxButtons.OK, MessageBoxIcon.Error) End Try End Sub'*-------------------------------------------------------------------*
' 【機 能】COMオブジェクトの解放 ' 【引 き 数】objCom : COMオブジェクト ' 【返 り 値】- '*-------------------------------------------------------------------* Public Sub COM_MRComObject(ByVal objCom As Object) 'COM オブジェクトの使用後、明示的に COM オブジェクトへの参照を解放する Try '提供されたランタイム呼び出し可能ラッパーの参照カウントをデクリメントします If Not objCom Is Nothing AndAlso System.Runtime.InteropServices. _ Marshal.IsComObject(objCom) Then Dim I As Integer Do I = System.Runtime.InteropServices.Marshal.ReleaseComObject(objCom) Loop Until I <= 0 End If Catch Finally objCom = Nothing End Try End Sub这个问题找两天了。终于知道是那儿的问题了。
原来是路径的问题。如果 SaveFileDialog1.InitialDirectory的值付的不正确.就会有
[このプログラムを使用してこの場所を開けません。 別の場所を試してください。]
这个问题.