アラサーになってから何だか体力の衰えと思考に変化があることを感じ始めている( --) ・・・・・
もう若くはないのね(;´Д`A ```
しかし誕生日を迎えていたことには変わりは無い＾＾そんな自分にご褒美ですYO!
ACSLが発売してたことは完全に忘れてた＾＾； しかし購入してから3日でシナリオクリア～。達成率は54％・・・まだ楽しめそうだわ( --) ・・・・・・
あと音楽作るDSソフトはいまだ未開封ｗ このまま積んでしまうのかなｗ あとキーボードも買った＾＾ワイアレスで入力も滑らか♪ これが3000円とかとても思えないわ＾＾
それと通勤用に手袋と耳当て買った＾＾ 手袋はイトーヨーカドーで20％引きだったらまたまた運がよかったわｗ
っとまぁ～こんな感じでゲームから便利なものまで色々買いましたわ＾＾
次はこれらを活かすことだわね
完成したソースを張っていなかった＾＾；
Option Explicit
'ページ設定のステータス受け取り箱
Dim para1 As String
Dim para2 As String
Dim para3 As String
Dim para4 As String
Dim para5 As String
Dim para6 As String
Dim para7 As String
Sub pageset() 'ユーザーが指定したディレクトリ内にあるxlsデータ全てのページ設定を変更する
Dim wb As Workbook
Dim strFnm As String
Dim strDir As String
Dim strDir2 As String
Dim toolwb As Workbook
Dim i As Integer
Dim AWN As String
Dim ShtCnt As Integer
Dim ShellApp As Object
Dim SaveFolder As Object
Dim TargetFolder As Object
'このツールの情報を取得
Set toolwb = ThisWorkbook
'処理をするディレクトリを決める
Set ShellApp = CreateObject("Shell.Application")
Set TargetFolder = ShellApp.BrowseForFolder(0, "処理を行うフォルダを選択してください。", 1)
If TargetFolder Is Nothing Then Exit Sub
'エラーチェック
If ThisWorkbook.Path = TargetFolder.items.Item.Path Then
MsgBox "このツールと同じフォルダにあるデータは処理できません。"
Exit Sub
End If
'保存するディレクトリを決める
Set SaveFolder = ShellApp.BrowseForFolder(0, "保存先フォルダを選択してください。", 1)
If SaveFolder Is Nothing Then Exit Sub
'処理を行うディレクトリ
strDir = TargetFolder.items.Item.Path
strDir2 = SaveFolder.items.Item.Path
'ツールの一覧シートにター別途フォルダの場所を記入
Cells(2, 3).Value = strDir
'処理を行う対象データ
strFnm = Dir(strDir & "\*.xls")
'警告ウインドウ非表示
Application.ScreenUpdating = False
i = 1
'処理開始
Do Until strFnm = ""
Set wb = Workbooks.Open(strDir & "\" & strFnm)
'処理内容
AWN = Left(wb.Name, Len(wb.Name) - 4)
ChDir (strDir2)
'処理前のステータスをリストに書き留める
toolwb.Activate
Cells(i + 6, 3).Value = wb.Name
Call para_in(wb)
Call page_status(i + 6, 4)
'ページ設定を変更する
wb.Activate
Call page_status_change
'処理後のステータスを書き留める
toolwb.Activate
Call para_in(wb)
Call page_status(i + 6, 11)
'処理を行ったデータを保存する
wb.Activate
ActiveWorkbook.Close savechanges:=True _
, Filename:=AWN & "_" & "pageset" & ".xls"
i = i + 1
strFnm = Dir() '次のファイル名
Loop
Application.ScreenUpdating = True
End Sub
Sub page_status(GYO As Integer, RETU As Integer) 'ページ設定のステータスを書き出し
If para1 = "1" Then
Cells(GYO, RETU).Value = "縦向き"
Else: Cells(GYO, RETU).Value = "横向き"
End If
Cells(GYO, RETU + 1).Value = para2
Cells(GYO, RETU + 2).Value = para3
Cells(GYO, RETU + 3).Value = para4
Cells(GYO, RETU + 4).Value = para5
Cells(GYO, RETU + 5).Value = para6
Cells(GYO, RETU + 6).Value = para7
End Sub
Sub para_in(wbook As Workbook) 'パラメータを変数に代入
para1 = CStr(wbook.ActiveSheet.PageSetup.Orientation)
para2 = CStr(wbook.ActiveSheet.PageSetup.Zoom)
para3 = CStr(wbook.ActiveSheet.PageSetup.FitToPagesWide)
para4 = CStr(wbook.ActiveSheet.PageSetup.FitToPagesTall)
para5 = CStr(wbook.ActiveSheet.PageSetup.PrintArea)
para6 = CStr(wbook.ActiveSheet.PageSetup.PrintTitleRows)
para7 = CStr(wbook.ActiveSheet.PageSetup.PrintTitleColumns)
End Sub
Private Sub page_status_change() 'ページ設定の変更処理
With ActiveSheet.PageSetup
.Orientation = 2 '印刷の向きを横にする
.Zoom = False '拡大縮小印刷設定を「次のページ数にあわせて印刷」に変更
.FitToPagesWide = 1 '上記のページ数横幅設定
.FitToPagesTall = False '同じく縦幅設定
.PrintTitleRows = "$1:$7" '行タイトルの設定
'.PrintArea = "" '印刷領域の設定
'.PrintTitleColumns = "" '列タイトルの設定
End With
End Sub
しかしまだ追加せねばいかん処理がまだあるんだよね＾＾； とりあえず今回はココまで
画像の３～６行目は事前に入力しないとダメなんで入力しておくこと。
印刷設定を一括して行うマクロを作ってた。ただ作るのもなんだか物足りないんでプロシージャ呼び出しとかで作ってみようと思ったんだわ。
っで、実際に作ったら何故か上手くいかない(´・ω・`) 引数の数値渡しは出来たんだが上手くいかないものだな( --) ・・・・・・
あと作ってて気付いたんだがVBAで配列使ったら宣言した配列の型通しじゃないと代入できなくてエラーになるのね(￣Д￣;;
Dim para(1 to 7) as String
Dim i As Integer
para(1) = i
Msgbox para(1)
これでエラーとか・・・。iをスとリング型にしてやると上手くいくとか。ちょっと面倒なんだけどわ
para(1) = CStr(i)
に書き換えると通ったわ。ちょっとこれはしんどいな(;´▽｀A`` 配列の使用には気をつけねば・・・。
今週はホントしんどかったわ(´・ω・`) マンションの壁の塗装工事といい、今いる丁度真下の部屋が夜中ずっと五月蝿くて寝れなかった日もあったから精神的にダウンしてたんだろうて・・・。
まぁ～これで静かになる・・・というか心が安らぐ空間が戻ってきたってところかな＾＾
ベランダに人がいるとか気分いいもんじゃないで・・・orz
ただ階段前の郵便受けはまだ外されたままで地面にじか置き状態( --) ・・・・・早く戻ってくれんかねぇ～。
さて、BVAの話。相変わらず買った本を読まずに自分のやって欲しい処理を行うマクロを作ろうとしてる＾＾；
そこで職場で役立ちそうなマクロを発見。こちらです。
このツールは指定したディレクトリ(フォルダ)の中にあるデータ、（サブディレクトリも含む）の一覧を記述するマクロ。
しかし全てのデータを記述するから困ったもの＾＾； そこでちょっとソースを追加
'拡張子がhtml,css,jsのみ記入
If (Right(objFILE.Name, 5) = ".html" Or Right(objFILE.Name, 4) = ".css" Or Right(objFILE.Name, 3) = ".js") Then
・・・・・
End If
と加えることで制限をかけれたわ＾＾
便利なツールも手を加えることで簡単に求めるものを作れるのは罪なものだねぇ～
