19年底做项目时自己写的工具，应该不会有改动，保存起来以后参考。
设计上比上一个工具好点，力求少复制粘贴，但增添新功能时依旧不太方便；
一开始以为基本设计是必须打开的就写死了，导致很多新增的功能也要先打开基本设计才能运行，后来懒得改了。
还有因为这个版本的vba依旧无法正常保存中文，所以没写注释，导致后来读写代码很不方便。
很多功能没有写，比如review的逻辑(非常有用但很难写的一块，打算多写些详细设计了解更多共同信息后再写，后来发现没必要写了)，递归的在单元格和shape里找字符串等。
主要收获是学会了一些格式设置的写法，和一些常用方法的参数的用法。
自用还行，如果给别人用还需改很多地方。
HPageBreaks是分页的属性，应该很有用
'common_functions模块
Public Function get_dto_arr_by_arr2d(ByVal arr2d)
Dim arr_help(), arr_res()
l1 = LBound(arr2d, 1)
l2 = LBound(arr2d, 2)
u1 = UBound(arr2d, 1)
u2 = UBound(arr2d, 2)
ReDim arr_help(l2 To u2)
ReDim arr_res(l1 To u1)
For i = l1 To u1
For j = l2 To u2
If arr2d(i, j) <> "" Then
arr_help(j) = arr2d(i, j)
GoTo over_j1
End If
Next j
j = l2 - 1
over_j1:
temp_dto = ""
For k = l2 To j
If arr_help(k) = "" Then
GoTo over_k1
End If
temp_dto = temp_dto & "." & arr_help(k)
Next k
If temp_dto = "" Then
temp_dto = Space(1)
End If
over_k1:
arr_res(i) = Right(temp_dto, Len(temp_dto) - 1)
Next i
get_dto_arr_by_arr2d = arr_res
Erase arr_help, arr_res
End Function
Public Function fast_start(Optional ByVal displayalert = True)
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
'.CalculateBeforeSave = False
.DisplayAlerts = displayalert
End With
End Function
Public Function fast_end()
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Function
Public Function replace_str_in_workbook(ByVal wb_ As Workbook, arr(), Optional replace_shape As Boolean = False)
lb = LBound(arr)
ub = UBound(arr)
'if ub-lb mod 2=1 then
Dim s As Shape
For i = lb To ub Step 2
Set wbsheets = wb_.Sheets
For j = 1 To wbsheets.Count
wbsheets(j).Cells.Replace arr(i), arr(i + 1), MatchCase:=False
If replace_shape Then
For Each s In wbsheets(j).Shapes
On Error Resume Next
With s.TextFrame2.TextRange
s_text = .Text
If s_text = "" Then
GoTo nexts
End If
index__ = InStr(1, s_text, arr(i), vbTextCompare)
If index__ < 1 Then
GoTo nexts
End If
s_text = Replace(s_text, arr(i), arr(i + 1), , , vbTextCompare)
s_text = Replace(s_text, vbTab, Space(4), , , vbTextCompare)
.Text = s_text
'If Not wb_.Name Like "*IF*" Then
' .Font.Name = "ＭＳ Ｐゴシック 本文"
' .Font.NameFarEast = "ＭＳ Ｐゴシック 本文"
' .Font.Size = 10
'End If
End With
nexts:
Next s
End If
Next j
Next i
End Function
Public Function set_sample_font(ByVal sh As Worksheet, Optional ByVal fontname = "Meiryo UI", Optional ByVal fontsize = 10)
Dim s As Shape
For Each s In sh.Shapes
On Error Resume Next
With s.TextFrame2.TextRange.Font
.Name = fontname
.Size = fontsize
.NameComplexScript = fontname
.NameFarEast = fontname
.NameAscii = fontname
.NameOther = fontname
End With
nexts:
Next s
End Function
Public Function set_fontsize(ByVal wb_ As Workbook, Optional fontsize = 10)
Dim s As Shape
Set wbsheets = wb_.Sheets
For j = 3 To wbsheets.Count
For Each s In wbsheets(j).Shapes
On Error Resume Next
With s.TextFrame2.TextRange.Font
.Size = 10
.Name = "Courier New"
End With
Next s
Next j
End Function
Public Function set_print_title(ByVal onesheet As Worksheet, Optional row_str = "$1:$3")
With onesheet.PageSetup
.PrintTitleRows = row_str
.PrintTitleColumns = ""
End With
End Function
Sub asd()
v = ThisWorkbook.Sheets(1).Range("a1").Value
index__ = InStr(-1, v, "勤務地", vbTextCompare)
End Sub
‘common_tools模块
Public Sub setCamel()
Set ran = Selection
With ActiveSheet
Set cur_ = .Cells(ran.Row, ran.Column)
colCount = cur_.Offset(0, 1).Column - cur_.Column
row_Count = ran.Count / colCount
For i = 1 To row_Count
.Cells(ran.Row + i - 1, ran.Column).Value = setOneCamel(.Cells(ran.Row + i - 1, ran.Column).Value)
Next i
End With
End Sub
Public Function setOneCamel(ByVal val)
arr = Split(val, "_")
val_ = arr(0)
For i = 1 To UBound(arr)
v_ = arr(i)
val_ = val_ & UCase(Left(v_, 1)) & Right(v_, Len(v_) - 1)
Next
setOneCamel = val_
End Function
Public Sub setActiveSheetShapeFont()
'myfontname = InputBox("insert your font name", Default:="ＭＳ Ｐゴシック 本文")
myfontname = InputBox("insert your font name", Default:="Meiryo UI")
Call set_sample_font(ActiveSheet, myfontname)
End Sub
Public Sub setMeiryoUI10()
With Selection.Font
.Name = "Meiryo UI"
.Size = 10
End With
End Sub
Public Function set_print_show(ByVal sh As Worksheet, ByVal set_head)
With sh.PageSetup
If set_head Then
.LeftHeader = "&""Meiryo UI,標準""&10&F"
End If
.RightFooter = "&""ＭＳ 明朝,標準""&8&P / &N "
.ScaleWithDocHeaderFooter = False
.AlignMarginsHeaderFooter = True
.LeftMargin = Application.InchesToPoints(0.393700787401575)
.RightMargin = Application.InchesToPoints(0.393700787401575)
.TopMargin = Application.InchesToPoints(0.590551181102362)
.BottomMargin = Application.InchesToPoints(0.590551181102362)
.HeaderMargin = Application.InchesToPoints(0.393700787401575)
.FooterMargin = Application.InchesToPoints(0.393700787401575)
End With
End Function
Public Sub paste_value()
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
End Sub
Public Sub get_height()
MsgBox Selection.Height
End Sub
Public Function check_borders(ByVal wbname As String, ByVal ws As Worksheet)
error_msg = ""
up_row = 1
down_row = 2
page_count = 1
title_height = ws.Rows(1).Height * 3
With ws
col = .Cells(1, 1).CurrentRegion.Count / 2
Set hps = .HPageBreaks
For i = 1 To hps.Count + 1
If i <= hps.Count Then
down_row = hps(i).Location.Row
Else
down_row = down_row + 1
While .Rows(down_row).PageBreak <> -4105
down_row = down_row + 1
If down_row - up_row > myconst.MAX_ONE_PAGE_ROW Then
'Err.Raise 6666, , "down_row-up_row>" & myconst.MAX_ONE_PAGE_ROW & ws.Name
'Debug.Print "down_row-up_row>" & myconst.MAX_ONE_PAGE_ROW & ws.Name
GoTo end_of_function
End If
Wend
End If
Set ran = .Range(.Cells(up_row, 1), .Cells(down_row - 1, col))
'ran.Select
current_height = ran.Height
If page_count > 1 Then
current_height = current_height + title_height
End If
For bb = 7 To 10
If ran.Borders(bb).LineStyle <> 1 Then
'Debug.Print wbname & " --> " & ws.Name & " --> page" & page_count & " border error"
error_msg = error_msg & wbname & Space(2) & ws.Name & " page" & page_count & " border有問題" & vbCrLf
GoTo border_over
End If
Next
border_over:
'Debug.Print wbname & " --> " & ws.Name & " --> page" & page_count & " --> " & current_height
If current_height > myconst.MAX_ONE_PAGE_HEIGHT Then
error_msg = error_msg & wbname & Space(2) & ws.Name & " page" & page_count & " 高度" & current_height & vbCrLf
End If
up_row = down_row
page_count = 1 + page_count
Next
End With
end_of_function:
check_borders = error_msg
End Function
Public Sub borders_syori_one_sheet()
Call borders_syori(ActiveSheet)
End Sub
Public Function borders_syori(ByVal ws As Worksheet)
Application.ScreenUpdating = False
up_row = 1
down_row = 2
With ws
col = .Cells(1, 1).CurrentRegion.Count / 2
Set hps = .HPageBreaks
For i = 1 To hps.Count + 1
If i <= hps.Count Then
down_row = hps(i).Location.Row
Else
down_row = down_row + 1
While .Rows(down_row).PageBreak <> -4105
down_row = down_row + 1
If down_row - up_row > 100 Then
'Err.Raise 6666, , "down_row-up_row>100" & ws.Name
Debug.Print "down_row-up_row>100" & ws.Name
Exit Function
End If
Wend
End If
Set ran = .Range(.Cells(up_row, 1), .Cells(down_row - 1, col))
from_row = up_row
If from_row = 1 Then
from_row = 5
End If
For e = from_row To down_row - 1
Set rr = .Range(.Cells(e, 1), .Cells(e, col))
xxx = rr.Borders(xlEdgeBottom).LineStyle
If xxx = 1 Then
rr.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
End If
Next e
ran.BorderAround xlContinuous, xlThin, 0
' For edge_ = 7 To 10
' With ran.Borders(edge_)
' .LineStyle = xlContinuous
'.Color = RGB(0, 0, 0)
'' .ColorIndex = 0
' .Weight = xlThin
' .TintAndShade = 0
'End With
'Next edge_
up_row = down_row
Next
End With
Application.ScreenUpdating = True
End Function
Public Function set_clipboard(ByVal s As String)
'把json保存到clipboard,1C3B4210-F441-11CE-B9EA-00AA006B1A69是clipboard的類標識符
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText s
.PutInClipboard
End With
End Function
'用selection生成json文字列、並保存到clipboard
'可生成黙認value、対[integer,int,long,float,double,string]有効
Public Sub generate_json()
Set ws = ActiveSheet
With Selection
start_row = .Row
start_col = .Column
col_count = UBound(.Value, 2)
row_Count = UBound(.Value, 1)
End With
generate_value_code = MsgBox("是否生成黙認value", vbYesNo)
s = "{"
j_prev = start_col
With ws
For i = start_row To start_row - 1 + row_Count
For j = start_col To start_col - 1 + col_count
If .Cells(i, j) <> "" Then
If j = j_prev + 1 Then
s = Left(s, Len(s) - 3) & Space(1) & "{"
ElseIf j = j_prev - 1 Then
s = Left(s, Len(s) - 1) & vbCrLf & Space(4 * (j - start_col + 1)) & "}"
End If
s = s & vbCrLf & Space(4 * (j - start_col + 1)) & """" & .Cells(i, j) & """:"
value_ = """"""
If Not LCase(Trim(.Cells(i, j).End(2).Value)) = "string" Then
value_ = "null"
End If
'------------------'生成黙認value start-------------------------
If generate_value_code = 6 Then
type_ = LCase(Trim(.Cells(i, j).End(2).Value))
Select Case type_
Case "integer", "int", "long"
value_ = 1
Case "float", "double"
value_ = 0.1
Case "string"
ronrimei = .Cells(i, j).End(1).Value
prefix_ = "001"
If InStr(ronrimei, "日本語") > 0 Then
value_ = """" & ronrimei & StrConv(prefix_, vbWide) & """"
Else
value_ = """" & .Cells(i, j).Value & prefix_ & """"
End If
End Select
End If
'------------------'生成黙認value end-------------------------
s = s & value_ & ","
j_prev = j
GoTo next_j1
End If
Next j
next_j1:
Next i
End With
For j_ = j - start_col To 0 Step -1
s = s & vbCrLf & Space(4 * j_) & "}"
Next j_
'Debug.Print s
Call set_clipboard(s)
'把json保存到clipboard,1C3B4210-F441-11CE-B9EA-00AA006B1A69是clipboard的類標識符
'With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
' .SetText s
' .PutInClipboard
'End With
End Sub
Public Sub perfect_save()
With ActiveWorkbook
For i = .Sheets.Count To 1 Step -1
.Sheets(i).Activate
.Sheets(i).Range("a1").Select
ActiveWindow.ScrollRow = 1
ActiveWindow.Zoom = 100
Next i
.Save
End With
End Sub
Public Sub add_depth()
Application.DisplayAlerts = False
Set ws = ActiveSheet
With Selection
.Font.Name = "Meiryo UI"
.Font.Size = 10
start_row = .Row
start_col = .Column
col_count = UBound(.Value, 2)
row_Count = UBound(.Value, 1)
If row_Count <= 1 Or col_count <= 1 Then
Err.Raise 6666, , "行数 or 列数＜＝１、操作不可" '這様写可以打印自定義的錯誤信息
End If
.UnMerge
End With
With ws
.Range(.Cells(start_row, start_col), .Cells(start_row, start_col + col_count - 1)).Merge
For i = start_row + 1 To start_row + row_Count - 1
.Range(.Cells(i, start_col + 1), .Cells(i, start_col + col_count - 1)).Merge
.Cells(i, start_col + 1).Value = .Cells(i, start_col).Value
Next i
Set ran1 = .Range(.Cells(start_row + 1, start_col), .Cells(start_row + row_Count - 1, start_col))
ran1.Merge
ran1.Borders.LineStyle = xlContinuous
ran1.Borders(xlEdgeTop).LineStyle = xlNone
ran1.ClearContents
End With
Application.DisplayAlerts = True
End Sub
'在ran里査找字符串kw，默認忽略大小写，完全相等査找
Public Function get_cell_by_kw_in_ran(ByVal ran As Range, ByVal kw, Optional ByVal ignore_case = False, Optional ByVal whole_or_part = xlWhole)
Set res = ran.Find(what:=kw, lookat:=whole_or_part, MatchCase:=ignore_case)
Set get_cell_by_kw_in_ran = res
End Function
Public Function get_folderpath()
Set FolderDialogObject = Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialogObject
.Title = "select your folder"
.InitialFileName = "C:\Users\×××\Desktop"
End With
FolderDialogObject.Show
get_folderpath = FolderDialogObject.SelectedItems(1)
End Function
'review详设模块
Public Function chech_borders_and_height_of_one_page(ByVal path1)
cursor_row = 1
ThisWorkbook.Sheets("reviewdata").Cells.ClearContents
Set fso = CreateObject("scripting.filesystemobject")
Set f1 = fso.getfolder(path1)
Set fs = f1.Files
For Each f In fs
Application.StatusBar = co & ":" & f.Path
co = co + 1
If Left(f.Name, 2) = "~$" Then
GoTo nextf
End If
On Error GoTo place1
Set wb = Workbooks.Open(f.Path)
If 0 > 1 Then
place1:
Set wb = Workbooks(f.Name)
End If
For i = 3 To wb.Sheets.Count
em = check_borders(f.Name, wb.Sheets(i))
'Debug.Print em
ems = Split(em, vbCrLf)
For r = LBound(ems) To UBound(ems)
ThisWorkbook.Sheets("reviewdata").Cells(cursor_row, 1) = ems(r)
cursor_row = cursor_row + 1
Next r
Next i
wb.Close False
nextf:
Next f
End Function
‘写詳設模块
Sub generate_request_param_by_selection()
aa = Selection.Value
For i = 1 To Workbooks.Count
bookname = Workbooks(i).Name
If bookname Like "*IF定義書*" Then
is_this = MsgBox("is name " & bookname & "???", vbYesNo)
If is_this = 6 Then
GoTo next_step
End If
End If
Next i
Err.Raise 6666, , "can not find *IF定義書* "
next_step:
Set ws = Workbooks(bookname).Sheets("IF定義")
r = get_cell_by_kw_in_ran(ws.Columns(3).Cells, "■REQUEST", True).Row + 3
co = 1
With ws
For i = LBound(aa) To UBound(aa)
If Trim(.Cells(r + co - 1, "c").Value) = "" Then
.Rows(r + co - 2).Copy
.Rows(r + co - 1).Insert
End If
.Cells(r + co - 1, "c").Value = co
.Cells(r + co - 1, "e").Value = aa(i, 1) '論理名
.Cells(r + co - 1, "m").Value = aa(i, 43) '物理名
.Cells(r + co - 1, "u").Value = "String" '型
If LCase(Right(aa(i, 43), 2)) = "pk" Then
.Cells(r + co - 1, "u").Value = "Integer"
End If
.Cells(r + co - 1, "ac").Value = aa(i, 19) '必須
'.Cells(r + co - 1, "ae").Value = aa(i, 1) '類型
.Cells(r + co - 1, "ag").Value = aa(i, 21) 'min値
.Cells(r + co - 1, "ah").Value = aa(i, 23) 'max値
.Cells(r + co - 1, "ak").Value = aa(i, 25) 'min桁数
.Cells(r + co - 1, "am").Value = aa(i, 27) 'max桁数
co = co + 1
Next i
End With
End Sub
Public Function rename_file_in_folder(ByVal path1 As String)
from_word = InputBox("insert from word", , ThisWorkbook.Sheets(1).Range("s1").Value)
to_word = InputBox("insert to word", , ThisWorkbook.Sheets(1).Range("t1").Value)
Set fso = CreateObject("scripting.filesystemobject")
Set f1 = fso.getfolder(path1)
Set fs = f1.Files
For Each f In fs
fp = f.Path
fp1 = Replace(fp, from_word, to_word, compare:=vbTextCompare)
Name fp As fp1
Next f
End Function
Public Sub get_basic_book_name()
For i = 1 To Workbooks.Count
bookname = Workbooks(i).Name
If bookname Like "*画面基本設計書*" Then
is_this = MsgBox("is name " & bookname & "???", vbYesNo)
If is_this = 6 Then
ThisWorkbook.Sheets(1).Range(myconst.BASIC_BOOK_ADDRESS) = bookname
Exit Sub
End If
End If
Next i
MsgBox "can not find any workbook name like *画面基本設計書*"
End Sub
Public Function syokika_syori_floder()
path1 = ThisWorkbook.Sheets(1).Range(myconst.SEIKABUTU_FOLDER_ADDRESS).Value
Set fso = CreateObject("scripting.filesystemobject")
Set f1 = fso.getfolder(path1)
Set fs = f1.Files
filenames = ""
reg = InputBox("please input edit file reg", Default:="詳細設計")
f_count_ = 0
For Each f In fs
fn_ = f.Name
If LCase(fn_) Like "*" & LCase(reg) & "*" Then
f_count_ = f_count_ + 1
filenames = filenames & Right(fn_, Len(fn_) - InStr(fn_, "】")) & vbCrLf
End If
Next f
msgres_ = MsgBox("find " & f_count_ & " files" & vbCrLf & filenames, vbYesNo)
If f_count_ = 0 Or msgres_ <> 6 Then
Exit Function
End If
co = 1
Dim wb As Workbook, bb As Workbook, bs As Worksheet, arr()
Set bb = Workbooks(ThisWorkbook.Sheets(1).Range(myconst.BASIC_BOOK_ADDRESS).Value)
Set bs = bb.Sheets(1)
bb_api_id = ""
bb_api_kanji = ""
With ThisWorkbook.Sheets(1)
If .CheckBoxes("idbox") = 1 Then
bb_api_id = bs.Cells(bs.Range("aL1").End(4).Row, "aL").Value
End If
If .CheckBoxes("kjbox") = 1 Then
v = bs.Range("i9").Value
bb_api_kanji = Left(v, InStr(v, Chr(10)) - 1)
End If
If .CheckBoxes("replacestrbox") = 1 Then
len_ = .Range("t33333").End(3).Row
ReDim arr(1 To len_ * 2)
temp_str = "do you want to replace words like next :"
For i = 1 To len_
If .Cells(i, "s") = "" Or .Cells(i, "t") = "" Then
Err.Raise 6666, , "empty string error"
End If
arr(2 * i - 1) = .Cells(i, "s")
arr(2 * i) = .Cells(i, "t")
temp_str = temp_str & vbCrLf & vbTab & .Cells(i, "s") & " --> " & .Cells(i, "t")
Next i
flg1 = MsgBox(temp_str, vbYesNo)
If flg1 <> 6 Then
Err.Raise 6666, , "replace error"
End If
End If
flg_borders_syori = False
If .CheckBoxes("borderssyoribox") = 1 Then
flg_border_syori_backup = MsgBox("will borders syori , backup ??", vbYesNo)
If flg_border_syori_backup = 6 Then
path2 = path1 & Replace(Date, "/", "_") & "-" & Replace(Time, ":", "_")
fso.copyfolder path1, path2
End If
flg_borders_syori = True
End If
shape_fontsize_flg = False
If .CheckBoxes("shapefontsizebox") = 1 Then
shape_fontsize_flg = True
End If
End With
flg1 = MsgBox("bb_api_kanji is " & bb_api_kanji & vbCrLf & "bb_api_id is " & bb_api_id, vbYesNo)
If flg1 <> 6 Then
Err.Raise 6666, , "name or id error"
End If
Call fast_start(False)
For Each f In fs
If Not LCase(f.Name) Like "*" & LCase(reg) & "*" Then
GoTo nextf
End If
'MsgBox f.Name
Application.StatusBar = co & ":" & f.Path
co = co + 1
If Left(f.Name, 2) = "~$" Then
GoTo nextf
End If
On Error GoTo place1
Set wb = Workbooks.Open(f.Path)
If 0 > 1 Then
place1:
Set wb = Workbooks(f.Name)
End If
Call common_set_詳設(wb, arr, bb_api_kanji, bb_api_id, flg_borders_syori)
If ThisWorkbook.Sheets(1).CheckBoxes("borderssyoribox") = 1 Then
For sh = 3 To wb.Sheets.Count
Call borders_syori(wb.Sheets(sh))
Next sh
End If
If ThisWorkbook.Sheets(1).CheckBoxes("printtitlebox") = 1 Then
For sh = 3 To wb.Sheets.Count
Call set_print_title(wb.Sheets(sh))
Next sh
End If
If ThisWorkbook.Sheets(1).CheckBoxes("setprintshow") = 1 Then
For sh = 1 To wb.Sheets.Count
Call set_print_show(wb.Sheets(sh), sh <> 1)
Next sh
End If
If ThisWorkbook.Sheets(1).CheckBoxes("setsamplefont") = 1 And wb.Name Like "*IF定義書*" Then
Call set_sample_font(wb.Sheets("IF定義"))
End If
If shape_fontsize_flg Then
Call set_fontsize(wb)
End If
wb.Activate
Call perfect_save
wb.Close
nextf:
Next f
Call fast_end
End Function
Public Function common_set_詳設(ByVal wb As Workbook, arr(), Optional ByVal api_kanji As String = "", _
Optional ByVal api_id As String = "", Optional ByVal flg_borders_syori = False)
With wb
last_row = .Sheets("表紙").Range("af33333").End(3).Row
If api_kanji <> "" Then
kanji = .Sheets("表紙").Range("i12").Value
len_temp = Len(kanji)
index_temp = InStr(kanji, "_")
index1 = IIf(index_temp < 1, len_temp, index_temp)
index_temp = InStr(kanji, "ー")
index2 = IIf(index_temp < 1, len_temp, index_temp)
index_temp = InStr(kanji, "-")
index3 = IIf(index_temp < 1, len_temp, index_temp)
index_ = WorksheetFunction.Min(index1, index2, index3)
kanji_ = api_kanji & Right(kanji, len_temp - index_ + 1)
'flg1 = MsgBox("kanji is " & kanji & vbCrLf & "will be --> " & kanji_, vbYesNo)
'If flg1 <> 6 Then
' Err.Raise 6666, , "api_kanji error"
'End If
.Sheets("表紙").Range("i12").Value = kanji_
End If
If api_id <> "" Then
api_id1 = .Sheets("表紙").Cells(last_row - 8, "al").Value
api_id_arr = Split(api_id1, "-")
For i = LBound(api_id_arr) + 2 To UBound(api_id_arr)
api_id = api_id & "-" & api_id_arr(i)
Next i
.Sheets("表紙").Cells(last_row - 8, "al").Value = api_id
End If
If ThisWorkbook.Sheets(1).CheckBoxes("daynamebox") = 1 Then
.Sheets("表紙").Cells(last_row - 2, "al").Value = Date
.Sheets("表紙").Cells(last_row, "al").Value = myconst.MY_NAME
End If
If ThisWorkbook.Sheets(1).CheckBoxes("replacestrbox") = 1 Then
Call replace_str_in_workbook(wb, arr, True)
End If
' .Sheets("修正履歴").Range("c5").Formula = "=as1"
' .Sheets("修正履歴").Range("ay5").Formula = "=ao1"
.Sheets("修正履歴").Range("c5").Value = .Sheets("修正履歴").Range("as1").Value
.Sheets("修正履歴").Range("ay5").Value = .Sheets("修正履歴").Range("ao1").Value
End With
End Function
’ThisWorkbook事件模块
Private Sub Workbook_Open()
With ThisWorkbook.Sheets(1)
.Range(myconst.SEIKABUTU_FOLDER_ADDRESS).Offset(0, 1).Value = .Range(myconst.SEIKABUTU_FOLDER_ADDRESS).Value
.Range(myconst.BASIC_BOOK_ADDRESS).Offset(0, 1).Value = .Range(myconst.BASIC_BOOK_ADDRESS).Value
.Range(myconst.SEIKABUTU_FOLDER_ADDRESS) = ""
.Range(myconst.BASIC_BOOK_ADDRESS) = ""
For Each chk In .CheckBoxes
chk.Value = -4146
Next chk
End With
End Sub
'myconst模块
Public Const MY_NAME As String = "myname"
Public Const BASIC_BOOK_ADDRESS As String = "a7"
Public Const SEIKABUTU_FOLDER_ADDRESS As String = "a2"
Public Const SEIKABUTU_TITLE_ADDRESS As String = "i12"
Public Const MAX_ONE_PAGE_ROW As Long = 40 '600/15.75
Public Const MAX_ONE_PAGE_HEIGHT As Long = 600
'controller模块
Sub ボタン1_Click()
Call syokika_syori_floder
End Sub
Sub ボタン2_Click()
path1 = get_folderpath()
If path1 = "" Then
Exit Sub
End If
Call set_clipboard(path1)
End Sub
Sub ボタン3_Click()
Call get_basic_book_name
End Sub
Sub ボタン8_Click()
Call rename_file_in_folder(ThisWorkbook.Sheets(1).Range(myconst.SEIKABUTU_FOLDER_ADDRESS).Value)
End Sub
Sub allselectbox_Click()
With ThisWorkbook.Sheets(1)
all_box_value = .CheckBoxes("allselectbox").Value
For Each c In .CheckBoxes
c.Value = all_box_value
Next c
End With
End Sub
'review
Sub ボタン13_Click()
path1 = InputBox("insert your review path")
If path1 = "" Then
Exit Sub
End If
Call chech_borders_and_height_of_one_page(path1)
End Sub
''''新增的数打印页数的功能
'ByVal wbname As String, ByVal ws As Worksheet
Sub countpages1()
s = "***.xlsx"
ss = "処理詳細"
sss = "修正履歴"
Set wb = Workbooks(s)
Set ws = Worksheets(sss)
ActiveWindow.View = xlPageBreakPreview
Set hps = ws.HPageBreaks
CC = hps.Count
End Sub
Function countpages(ByVal wb As Workbook)
'ActiveWindow.View = xlPageBreakPreview
nums = 0
For i = 1 To wb.Sheets.Count
Set ws = Worksheets(i)
num = ws.HPageBreaks.Count
If Not isLastPageBreakReal(ws) Then
num = num + 1
End If
'Debug.Print ws.Name & ":" & num
nums = num + nums
Next i
'Debug.Print wb.Name & "@@@" & nums
Set rs = ThisWorkbook.Sheets("reviewdata")
With rs
lr = getwriterow(rs) + 1
'MsgBox lr
.Cells(lr, 1) = wb.Name
.Cells(lr, 2) = nums
End With
'countpages = wb.Name & "@@@" & nums
End Function
Function getwriterow(ByVal rs As Worksheet)
lr = rs.Cells(33333, 1).End(xlUp).Row
'lr = Application.Max(lr, rs.Cells(33333, 2).End(xlUp).Row)
getwriterow = lr
End Function
Function isLastPageBreakReal(ByVal ws As Worksheet, Optional offsetrow = 40, Optional offsetcol = 40)
With ws
Set zzz = .HPageBreaks
If zzz.Count = 0 Then
isLastPageBreakReal = False
Exit Function
End If
Set yyy = zzz(zzz.Count)
rowyyy = yyy.Location.Row
Set ran1 = ws.Range(ws.Cells(rowyyy, 1), ws.Cells(rowyyy + offsetrow, 1 + offsetcol))
contentyyy = Trim(WorksheetFunction.Phonetic(ran1))
isLastPageBreakReal = (contentyyy = "")
End With
End Function
Sub ttt()
Call a1
's = "****.xlsx"
'Set wb = Workbooks(s)
'Debug.Print countpages(wb)
End Sub
Public Function countpagesofpath(ByVal path1, ByVal fso)
Set rs = ThisWorkbook.Sheets("reviewdata")
lr = getwriterow(rs) + 1
rs.Cells(lr, 1) = path1
'Set fso = CreateObject("scripting.filesystemobject")
Set f1 = fso.getfolder(path1)
Set fs = f1.Files
For Each f In fs
Application.StatusBar = co & ":" & f.Path
co = co + 1
If Left(f.Name, 2) = "~$" Then
GoTo nextf
End If
On Error GoTo place1 ''''没有考虑其他文件
Set wb = Workbooks.Open(f.Path)
If 0 > 1 Then
place1:
Set wb = Workbooks(f.Name)
End If
countpages (wb)
wb.Close False
nextf:
Next f
'fso = Null
End Function
Sub tt1t()
ThisWorkbook.Sheets("reviewdata").Cells.ClearContents
s = "C:\****"
'countpagesofpath (s)
End Sub
Sub a1()
Call fast_start
Set rs = ThisWorkbook.Sheets("reviewdata")
rs.Cells.ClearContents
path1 = "C:\Users\user\Desktop\3\****"
path1 = "C:\Users\user\Desktop\3"
Set fso = CreateObject("scripting.filesystemobject")
Call walk(fso, path1)
Call fast_end
End Sub
Function walk(ByVal fso, ByVal path1 As String)
Call countpagesofpath(path1, fso)
Set folders1 = fso.getfolder(path1)
For Each i In folders1.Files
'Debug.Print i.Path & fso.GetExtensionName(i.Name)
''''fso.GetExtensionName(s)获取s的后缀名，s如果是文件夹或者没有后缀名返回空字符串
Next i
For Each i In folders1.subfolders
Call walk(fso, i.Path)
Next i
End Function
889
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
