teacup. [ 掲示板 ] [ 掲示板作成 ] [ 有料掲示板 ] [ ブログ ]


新着順:10/21 記事一覧表示 | 《前のページ | 次のページ》

「Excel変換」アクションボタン(4/4)

 投稿者:anon12  投稿日:2008年 6月 1日(日)16時56分56秒
  通報 返信・引用
  「Excel変換」アクションボタン(4/4)
--------------------------------------

     REM *********************************************
     REM *   フォントの種類とフォントサイズを設定します。    *
     REM *********************************************
XlApp.Range("A1:P" + Trim$(Cstr(Excel行番号))).Select
XlApp.Selection.Font.Name = "Arial"
XlApp.Selection.Font.Size = 9
     REM *********************************
     REM *   下記のページ設定を行います。    *
     REM *     (1)印刷の向き                      *
     REM *     (2)拡大/縮小                      *
     REM *     (3)用紙サイズ                      *
     REM *     (4)余白                               *
     REM *     (5)ヘッダー、フッター              *
     REM *     (6)印刷タイトル行                  *
     REM *********************************
On Error Goto ErrHandler
With XlApp.Worksheets(ワークシート名)
.PageSetup.orientation = xlLandscape               ' 印刷の向き(横)を設定します。
.PageSetup.Zoom = 80                                  ' 拡大/縮小を設定します。
.PageSetup.PaperSize = xlPaperA3                   ' 用紙サイズを設定します。
.PageSetup.LeftMargin = xlApp.CentimetersToPoints(0.5)                   ' 余白を設定します。
.PageSetup.RightMargin = xlApp.CentimetersToPoints(0.5)
.PageSetup.TopMargin = xlApp.CentimetersToPoints(2.5)
.PageSetup.BottomMargin = xlApp.CentimetersToPoints(2.5)
.PageSetup.HeaderMargin = xlApp.CentimetersToPoints(1.3)
.PageSetup.FooterMargin = xlApp.CentimetersToPoints(1.3)
.Pagesetup.centerheader = "&B &12 データベース使用者一覧(詳細)"  ' ヘッダー、フッターを設定します。
.Pagesetup.Rightheader = "" + Chr(13) + "作成者:" + 作成者 + "  作成日:" + 作成日
.Pagesetup.RightFooter = "ページ: &P/&N" + "  印刷日: &D"
.Pagesetup.CenterFooter = ""
.PageSetup.PrintTitleRows = "$1:$1"                ' 印刷タイトル行を設定します。
End With
On Error Goto 0
     REM ****************************
     REM *   ウィンドウ枠を固定します。   *
     REM ****************************
XlApp.Range("A1").CurrentRegion.Select
XlApp.ActiveCell.Offset(1, 0).Select
XlApp.ActiveWindow.FreezePanes = True
     REM ******************************
     REM *   セルの背景色を設定します。   *
     REM ******************************
For i = 2 To Excel行番号
If ((i Mod 2) = 0) Then
XlApp.Range("A" + Trim$(Cstr(i)) + ":P" + Trim$(Cstr(i))).Interior.ColorIndex = 35
End If
Next
xlApp.Workbooks(1).Worksheets(ワークシート名).Name = "詳細"  ' ワークシート名を変更します。
xlApp.DispLayALerts = False                                       ' Excelの警告メッセージを表示しない様にします。
     REM ************************************************************************
     REM *   データベース使用者一覧の「ノーツユーザ数」をExcelファイル上へ作成します。   *
     REM ************************************************************************
ワークシート検索キー = ワークシート検索キー + 1
ワークシート名 = ワークシートテーブル(ワークシート検索キー)
xlApp.Workbooks(1).Worksheets(ワークシート名).Activate
Set xlsheet = xlApp.Workbooks(1).Worksheets(ワークシート名)
With xlsheet
.Range("B5").Value = "アクセス権"
.Range("B6").Value = "[管理者]"
.Range("B7").Value = "[設計者]"
.Range("B8").Value = "[編集者]"
.Range("B9").Value = "[作成者]"
.Range("B10").Value = "[読者]"
.Range("B11").Value = "[投稿者]"
.Range("B12").Value = "[なし]"
.Range("B13").Value = "??"
.Range("B14").Value = "合計"
.Range("B17").Value = "合計"
.Range("B18").Value = "削除数"
.Range("B19").Value = "総数"
.Range("C5").Value = "ノーツユーザ数"
.Range("C6").Value = Cstr(ノーツユーザ管理者数)
.Range("C7").Value = Cstr(ノーツユーザ設計者数)
.Range("C8").Value = Cstr(ノーツユーザ編集者数)
.Range("C9").Value = Cstr(ノーツユーザ作成者数)
.Range("C10").Value = Cstr(ノーツユーザ読者数)
.Range("C11").Value = Cstr(ノーツユーザ投稿者数)
.Range("C12").Value = Cstr(ノーツユーザなし数)
.Range("C13").Value = Cstr(ノーツユーザ不定数)
.Range("C14").Formula = "=SUM(C6:C13"
.Range("C16").Value = "ノーツユーザ数"
.Range("C17").Formula = "=SUM(C6:C13"
.Range("C18").Value = Cstr(ノーツユーザ削除数)
.Range("C19").Value = ノーツユーザ総数
.Range("D6:D14").Value = "人"
.Range("D17:D19").Value = "人"
End With
Xlapp.columns("B:D").Select
XlApp.Selection.Columns.AutoFit
     REM **************************************
     REM *   セルデータの横位置を最適化します。    *
     REM **************************************
XlApp.Range("B5:B19").HorizontalAlignment = xlCenter           ' セルデータの位置を中央揃えに配置します。
XlApp.Range("C5").HorizontalAlignment = xlCenter                ' セルデータの位置を中央揃えに配置します。
XlApp.Range("C6:C14").HorizontalAlignment = xlHAlignRight    ' セルデータの位置を右詰に配置します。
XlApp.Range("C16").HorizontalAlignment = xlCenter               ' セルデータの位置を中央揃えに配置します。
XlApp.Range("C17:C19").HorizontalAlignment = xlHAlignRight   ' セルデータの位置を右詰に配置します。
XlApp.Range("D5:D19").HorizontalAlignment = xlHAlignLeft      ' セルデータの位置を左詰に配置します。
     REM **************************
     REM *   表に罫線を設定します。   *
     REM **************************
XlApp.Range("B5:D14").Select
With XlApp.Selection
.Borders(1).Weight = 2                                   ' セルの左
.Borders(2).Weight = 2                                   ' セルの右
.Borders(3).Weight = 2                                   ' セルの上
.Borders(4).Weight = 2                                   ' セルの下
End With
XlApp.Range("C5:C14").Borders(2).LineStyle = -4142    ' セルの右の罫線を「無し」にします。
XlApp.Range("D5:D14").Borders(1).LineStyle = -4142    ' セルの左の罫線を「無し」にします。
XlApp.Range("B14:D14").Borders(3).Weight = -4138      ' セルの上の罫線を「重線」にします。
XlApp.Range("B16:D19").Select
With XlApp.Selection
.Borders(1).Weight = 2                                   ' セルの左
.Borders(2).Weight = 2                                   ' セルの右
.Borders(3).Weight = 2                                   ' セルの上
.Borders(4).Weight = 2                                   ' セルの下
End With
XlApp.Range("B16:B16").Select
With XlApp.Selection
.Borders(6).LineStyle = 2
End With
XlApp.Range("C16:C19").Borders(2).LineStyle = -4142    ' セルの右の罫線を「無し」にします。
XlApp.Range("D16:D19").Borders(1).LineStyle = -4142    ' セルの左の罫線を「無し」にします。
XlApp.Range("B19:D19").Borders(3).Weight = -4138       ' セルの上の罫線を「重線」にします。
     REM **********************
     REM *   セルを結合します。   *
     REM **********************
XlApp.Range("C5:D5").Select
With XlApp.Selection
.MergeCells = True
End With
XlApp.Range("C16:D16").Select
With XlApp.Selection
.MergeCells = True
End With
     REM *********************************************
     REM *   フォントの種類とフォントサイズを設定します。    *
     REM *********************************************
XlApp.Range("B5:D19").Select
XlApp.Selection.Font.Name = "Arial"
XlApp.Selection.Font.Size = 9
     REM ********************************
     REM *   下記のページ設定を行います。   *
     REM *     (1)印刷の向き                     *
     REM *     (2)拡大/縮小                     *
     REM *     (3)用紙サイズ                     *
     REM *     (4)余白                              *
     REM *     (5)ヘッダー、フッター             *
     REM *     (6)印刷タイトル行                 *
     REM ********************************
With XlApp.Worksheets(ワークシート名)
.PageSetup.orientation = xlLandscape               ' 印刷の向き(横)を設定します。
.PageSetup.Zoom = 100                                 ' 拡大/縮小を設定します。
.PageSetup.PaperSize = xlPaperA4                   ' 用紙サイズを設定します。
.PageSetup.LeftMargin = xlApp.CentimetersToPoints(0.5)                               ' 余白を設定します。
.PageSetup.RightMargin = xlApp.CentimetersToPoints(0.5)
.PageSetup.TopMargin = xlApp.CentimetersToPoints(2.5)
.PageSetup.BottomMargin = xlApp.CentimetersToPoints(2.5)
.PageSetup.HeaderMargin = xlApp.CentimetersToPoints(1.3)
.PageSetup.FooterMargin = xlApp.CentimetersToPoints(1.3)
.Pagesetup.centerheader = "&B &12 データベース使用者一覧(ノーツユーザ数)" ' ヘッダー、フッターを設定します。
.Pagesetup.Rightheader = "" + Chr(13) + "作成者:" + 作成者 + "  作成日:" + 作成日
.Pagesetup.RightFooter = "ページ: &P/&N" + "  印刷日: &D"
.Pagesetup.CenterFooter = ""
.PageSetup.PrintTitleRows = "$1:$1"                ' 印刷タイトル行を設定します。
End With
xlApp.Workbooks(1).Worksheets(ワークシート名).Name = "ノーツユーザ数"  ' ワークシート名を変更します。
XlApp.Range("B5:D19").Select
XlApp.Selection.Locked = True                                     ' 全てのセルをロックします。
xlApp.Workbooks(1).Worksheets("ノーツユーザ数").Protect ' 「ノーツユーザ数」ワークシートを保護します。
xlApp.Workbooks(1).Worksheets("概要").Activate     ' 「概要」ワークシートをアクティブにします。
Redim 削除ワークシートテーブル(1 To ワークシート数) As String
削除ワークシート数 = 0
For i = 1 To ワークシート数
If ((xlApp.Workbooks(1).Worksheets(i).Name <> "概要")            And _
(xlApp.Workbooks(1).Worksheets(i).Name <> "ノーツユーザ数")  And _
(xlApp.Workbooks(1).Worksheets(i).Name <> "詳細"))                       Then
削除ワークシート数 = 削除ワークシート数 + 1
削除ワークシートテーブル(削除ワークシート数) = xlApp.Workbooks(1).Worksheets(i).Name
End If
Next
For i = 1 To 削除ワークシート数
削除ワークシート名 = 削除ワークシートテーブル(i)
xlApp.Workbooks(1).Worksheets(削除ワークシート名).Delete
Next

BeepSec = Csng("2")
BeepCounter = BeepOn(BeepSec)
BoxTitle = userName.Abbreviated + " さん"
Message = "データベース使用者一覧のExcelファイルへの変換が終了しました!"
BoxType = 0 + 48
Answer = Messagebox (Message,BoxType,BoxTitle)
xlApp.Visible = True
Exit Sub
'   エラー処理ルーチン   *
ErrHandler:
XlApp.Worksheets(ワークシート名).PageSetup.PaperSize = xlPaperA4 ' 用紙サイズを設定します。
Resume Next
End Sub
 
 
》記事一覧表示

新着順:10/21 《前のページ | 次のページ》
/21