Public Const AppName As String = "AutoCad"
Public Const AppVersion As Integer = 2019
Public IgoreTextList As Variant
Public Const ZuWakuBlockname As String = "HIN1_AS_ENG"
Public Const WSName As String = "ExportText"
Public Const ProcessWSName As String = "Process"
Sub JHS01_ExportText2Excel()
Application.ScreenUpdating = False
Application.EnableEvents = False
'Settings
Dim ClearOldColumnFromLetter As String: ClearOldColumnFromLetter = "C"
Dim ClearOldColumnToLetter As String: ClearOldColumnToLetter = "N"
'Select Files
Dim fnameList As Variant
fnameList = Application.GetOpenFilename(FileFilter:="AutoCad File (*.dwg),*.dwg", Title:="Choose Autocad files", MultiSelect:=True)
If (vbBoolean = VarType(fnameList)) Then
MsgBox "No files selected"
GoTo GTES
End If
'Define VersionAppValue
Dim GetAppValue As Variant
Dim AppValue As String
GetAppValue = JHF03_DefineVersionAppValue(AppName, AppVersion)
If VarType(GetAppValue) = vbBoolean Then
MsgBox "Can not define CAD Application Version Value"
GoTo GTES
Else
AppValue = GetAppValue
End If
'Startup Cad Application
Dim AcadApp As AutoCAD.AcadApplication
Set AcadApp = JHF04_StartupAutoCad(AppValue)
'Define WS
Dim WS As Worksheet
Dim ProcessWS As Worksheet
Set WS = ThisWorkbook.Sheets(WSName)
Set ProcessWS = ThisWorkbook.Sheets(ProcessWSName)
'Creat IgoreTextList
IgoreTextList = JHF01_CrearArrFromWSColumn(WS, 1, 2)
'Clear Old Data and Color
Call JHF02_Call_ClearDataCellFontColorOfRange(WS, ClearOldColumnFromLetter, ClearOldColumnToLetter, 2)
'Process
Dim EachFilePath As Variant
Dim EachFileName As String
Dim CountFiles As Integer
Dim EachDrawing As AcadDocument
Dim EachSS As AcadSelectionSet
Dim GetEachSS As Boolean
Dim ProcessErr As Boolean
Dim EachEndRowRange As Integer
Dim EachEndRowFilePathColumn As Integer
Dim ButtonMode As VbMsgBoxStyle
Dim MsgMain As String
Dim MsgYes As String
Dim MsgNo As String
Dim MsgCancel As String
Dim Response As VbMsgBoxResult
Dim Count_Total As Integer
Dim Count_Finished As Integer
Dim Count_Err As Integer
Dim Count_TotalRowImport As Integer
Dim Count_EachRowImport As Integer
Count_Total = UBound(fnameList)
For Each EachFilePath In fnameList
'Open File(Read Only)
Set EachDrawing = JHF05_OpenCadFile_AutoCad(AcadApp, EachFilePath, True)
'Define FileName
EachFileName = EachDrawing.Name
EachFileName = Before_(EachFileName, ".")
'Select Layout Contain WakuBlock
Call JHF06X_Call_SelectLayoutContainWakuBlock(EachDrawing, ZuWakuBlockname)
GTSelectText:
'Clear OldData in ProcessWS
Call JHF02_Call_ClearDataCellFontColorOfRange(ProcessWS, "A", "L", 2)
'Select Texts
GetEachSS = JHF07_SelectOnScreen(EachDrawing, EachSS, "TEXT")
If GetEachSS = False Then
GoTo GTCloseFile
End If
'Get Information of Texts and write to ProcessWS
Call JHF09X_Call_WriteTextInfoToExcel(EachSS, ProcessWS)
EachSS.Erase
EachSS.Delete
'Arrange Text
Call JHS02_ArrangeText(ProcessErr)
'MsgBox when Error
If ProcessErr = True Then
ButtonMode = vbYesNoCancel
MsgMain = "Warning: Can not define Table"
MsgYes = "Close Current File. Continue"
MsgNo = "Select Text Again"
MsgCancel = "Exit Command"
Call JHF19_Call_MsgBox_SelectMode(ButtonMode, MsgMain, MsgYes, MsgNo, MsgCancel, Response)
Select Case Response
Case vbYes
GoTo GTCloseFile
Count_Err = Count_Err + 1
Case vbNo
GoTo GTSelectText
Case vbCancel
Call JHF02_Call_ClearDataCellFontColorOfRange(WS, ClearOldColumnFromLetter, ClearOldColumnToLetter, 2)
Count_Finished = 0
GoTo GTES
End Select
End If
'Write FilePath,FileName to WS
EachEndRowRange = JHF18_DefineEndRowOfRange(WS, "C", "O")
Call HCF4079_DefineRowEndNo(WS, EachEndRowFilePathColumn, 3)
WS.Range(WS.Cells(EachEndRowFilePathColumn + 1, 3), WS.Cells(EachEndRowRange, 3)).Value = EachFilePath
WS.Range(WS.Cells(EachEndRowFilePathColumn + 1, 4), WS.Cells(EachEndRowRange, 4)).Value = EachFileName
'Count Import Row
Count_EachRowImport = EachEndRowRange - EachEndRowFilePathColumn
Count_TotalRowImport = Count_TotalRowImport + Count_EachRowImport
'Continue Select Text
ButtonMode = vbYesNoCancel
MsgMain = "Continue Or More Select Text"
MsgYes = "Close Current File. Continue"
MsgNo = "More Select Text"
MsgCancel = "Exit Command"
Call JHF19_Call_MsgBox_SelectMode(ButtonMode, MsgMain, MsgYes, MsgNo, MsgCancel, Response)
Select Case Response
Case vbYes
Count_Finished = Count_Finished + 1
Case vbNo
GoTo GTSelectText
Case vbCancel
Call JHF02_Call_ClearDataCellFontColorOfRange(WS, ClearOldColumnFromLetter, ClearOldColumnToLetter, 2)
Count_Finished = 0
GoTo GTES
End Select
GTCloseFile:
If AcadApp.Documents.Count > 1 Then
EachDrawing.Close False
End If
Next
GTES:
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Select " & Count_Total & " Files" & vbNewLine & _
Count_Finished & " / " & Count_Total & "Finished" & vbNewLine & _
"Imported Total " & Count_TotalRowImport & " Rows" & vbNewLine & _
Count_Err & " Error"
End Sub
Sub JHS02_ArrangeText(ProcessErr As Boolean)
Application.ScreenUpdating = False
Application.EnableEvents = False
'Settings
Dim FinishedColorInder As Integer: FinishedColorInder = 4
Dim TextLenCNo As Integer: TextLenCNo = 9
'Define WS and EndRow
Dim WS As Worksheet
Dim ProcessWS As Worksheet
Set WS = ThisWorkbook.Sheets(WSName)
Set ProcessWS = ThisWorkbook.Sheets(ProcessWSName)
'Define EndRow of ProcessWS
Dim EndRow As Integer
Call HCF4079_DefineRowEndNo(ProcessWS, EndRow, 1)
If EndRow = 1 Then
ProcessErr = True
GoTo GTES
End If
'Define MinTextHeght
Dim MinTextHeight As Double
Dim TextHeightRange As Range
Set TextHeightRange = ProcessWS.Range("J:J")
MinTextHeight = WorksheetFunction.Min(TextHeightRange)
'Define TableColumnGroup by TextLen
Dim GetMaxValue As Boolean
Dim MaxValue As Double
Dim MaxValue_RNo As Integer
Dim MaxValue_MinXorY As Double
Dim MaxValue_MidXorY As Double
Dim MaxValue_MaxXorY As Double
Dim RNo As Integer
Dim EachMidXorY As Double
Dim EachCompareResult As Boolean
Do
GetMaxValue = JHF11_DefineMinMaxValueAndPosition_IgoreColorIndex(ProcessWS, FinishedColorInder, TextLenCNo, 2, EndRow, "Max", MaxValue, MaxValue_RNo)
If GetMaxValue = False Then
GoTo GTNS1
Else
'Define MaxValue X Value
MaxValue_MinXorY = ProcessWS.Cells(MaxValue_RNo, 3).Value
MaxValue_MidXorY = ProcessWS.Cells(MaxValue_RNo, 4).Value
MaxValue_MaxXorY = ProcessWS.Cells(MaxValue_RNo, 5).Value
'Fill Color
Call Func17BSetCellColorIndex(ProcessWS, MaxValue_RNo, TextLenCNo, TextLenCNo, FinishedColorInder)
Call Func17BSetCellColorIndex(ProcessWS, MaxValue_RNo, 3, 5, FinishedColorInder)
End If
'Check MaxValue_MinXorY <= EachMidXorY <= MaxValue_MaxXorY
'Match Value
'FillColor
For RNo = 2 To EndRow
EachCompareResult = JHF12_CompareValueWithMinMax_IgoreColorIndex(ProcessWS, FinishedColorInder, RNo, 4, MaxValue_MinXorY, MaxValue_MaxXorY)
If EachCompareResult = True Then
ProcessWS.Cells(RNo, TextLenCNo).Value = MaxValue
ProcessWS.Cells(RNo, 3).Value = MaxValue_MinXorY
ProcessWS.Cells(RNo, 4).Value = MaxValue_MidXorY
ProcessWS.Cells(RNo, 5).Value = MaxValue_MaxXorY
Call Func17BSetCellColorIndex(ProcessWS, RNo, TextLenCNo, TextLenCNo, FinishedColorInder)
Call Func17BSetCellColorIndex(ProcessWS, RNo, 3, 5, FinishedColorInder)
End If
Next
GTNS1:
Loop While GetMaxValue = True
'Define TableRowGroup by MidY
Do
GetMaxValue = JHF11_DefineMinMaxValueAndPosition_IgoreColorIndex(ProcessWS, FinishedColorInder, 7, 2, EndRow, "Max", MaxValue, MaxValue_RNo)
If GetMaxValue = False Then
GoTo GTNS2
Else
'Define MaxValue Y Value
MaxValue_MidXorY = ProcessWS.Cells(MaxValue_RNo, 7).Value
MaxValue_MinXorY = MaxValue_MidXorY - MinTextHeight
MaxValue_MaxXorY = MaxValue_MidXorY + MinTextHeight
ProcessWS.Cells(MaxValue_RNo, 6).Value = MaxValue_MinXorY
ProcessWS.Cells(MaxValue_RNo, 8).Value = MaxValue_MaxXorY
'Fill Color
Call Func17BSetCellColorIndex(ProcessWS, MaxValue_RNo, 6, 8, FinishedColorInder)
End If
'Check MaxValue_MinXorY <= EachMidXorY <= MaxValue_MaxXorY
'Match Value
'FillColor
For RNo = 2 To EndRow
EachCompareResult = JHF12_CompareValueWithMinMax_IgoreColorIndex(ProcessWS, FinishedColorInder, RNo, 7, MaxValue_MinXorY, MaxValue_MaxXorY)
If EachCompareResult = True Then
ProcessWS.Cells(RNo, 6).Value = MaxValue_MinXorY
ProcessWS.Cells(RNo, 7).Value = MaxValue_MidXorY
ProcessWS.Cells(RNo, 8).Value = MaxValue_MaxXorY
Call Func17BSetCellColorIndex(ProcessWS, RNo, 6, 8, FinishedColorInder)
End If
Next
GTNS2:
Loop While GetMaxValue = True
'Creat List of MidX
Dim MidXArr As Variant
MidXArr = JHF13_CreatListValueAndSort_NumberType(ProcessWS, 4, 2, "SortAtoZ")
'Creat List of MidY
Dim MidYArr As Variant
MidYArr = JHF13_CreatListValueAndSort_NumberType(ProcessWS, 7, 2, "SortZtoA")
'Write TableRNo to ProcessWS
Call JHF15X_WriteTableRNoCNoToProcessWS(ProcessWS, MidYArr, 7, 11, 2, EndRow)
'Write TableCNo to ProcessWS
Call JHF15X_WriteTableRNoCNoToProcessWS(ProcessWS, MidXArr, 4, 12, 2, EndRow)
'Define Table_Total Column,Row
Dim Table_TotalRow As Double
Dim Table_TotalColumn As Double
Table_TotalRow = JHF16_MinMaxValueAtColumnOfWS(ProcessWS, 11, "Max")
Table_TotalColumn = JHF16_MinMaxValueAtColumnOfWS(ProcessWS, 12, "Max")
'Creat Table_TextString()
Dim GetTable As Boolean
Dim Table_TextString() As String
ReDim Table_TextString(1 To Table_TotalRow, 1 To Table_TotalColumn)
GetTable = JHF17X_CreatTableVale(ProcessWS, Table_TextString, 2, 2, EndRow)
If GetTable = False Then
ProcessErr = True
GoTo GTES
End If
'Creat Table_Handle()
Dim Table_Handle() As String
ReDim Table_Handle(1 To Table_TotalRow, 1 To Table_TotalColumn)
GetTable = JHF17X_CreatTableVale(ProcessWS, Table_Handle, 1, 2, EndRow)
If GetTable = False Then
ProcessErr = True
GoTo GTES
End If
'Write Table_Handle to WS
'Write Table_TextString to WS
Dim WSEndrow As Integer
Dim WriteRNo As Integer
Call HCF4079_DefineRowEndNo(WS, WSEndrow, 3)
Dim EachTextString As String
Dim EachHandle As String
Dim WriteCNo_Text As Integer
Dim WriteCNo_Handle As Integer
For i = LBound(Table_Handle) To UBound(Table_Handle)
WriteRNo = WSEndrow + i
For k = LBound(Table_Handle, 2) To UBound(Table_Handle, 2)
WriteCNo_Handle = k + 4
WriteCNo_Text = k + 9
EachHandle = Table_Handle(i, k)
EachTextString = Table_TextString(i, k)
WS.Cells(WriteRNo, WriteCNo_Handle).Value = EachHandle
WS.Cells(WriteRNo, WriteCNo_Text).Value = EachTextString
Next
Next
'Clear OldData In Process WS
Call JHF02_Call_ClearDataCellFontColorOfRange(ProcessWS, "A", "L", 2)
'ExitSub
GTES:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub JHS03_UpdateChange()
Application.ScreenUpdating = False
Application.EnableEvents = False
'Define VersionAppValue
Dim GetAppValue As Variant
Dim AppValue As String
GetAppValue = JHF03_DefineVersionAppValue(AppName, AppVersion)
If VarType(GetAppValue) = vbBoolean Then
MsgBox "Can not define CAD Application Version Value"
GoTo GTES
Else
AppValue = GetAppValue
End If
'Define WS
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets(WSName)
'Define EndRow
Dim EndRow As Integer
Call HCF4079_DefineRowEndNo(WS, EndRow, 3)
If EndRow < 2 Then GoTo GTES
'Creat UpdateArr(FilePath,Handle,Value)
Dim UpdateArr() As String: Dim aa As Integer
Dim EachUpdate As String
Dim Delimited As String: Delimited = "***"
Dim RNo As Integer
Dim CNo As Integer
Dim EachPathRange As Range
Dim EachPath As String
Dim EachPathColorIndex As Integer
Dim EachTextRange As Range
Dim EachText As String
Dim EachTextColorIndex As Integer
Dim EachHandle As String
Dim UpdateTotal As Integer
For RNo = 2 To EndRow
'Check Color of PathFile
Set EachPathRange = WS.Cells(RNo, 3)
EachPath = WS.Cells(RNo, 3).Value
EachPathColorIndex = EachPathRange.Interior.ColorIndex
If EachPathColorIndex <> 6 Then GoTo GTSkip
For CNo = 10 To 14
'Check Color of TextRange
Set EachTextRange = WS.Cells(RNo, CNo)
EachTextColorIndex = EachTextRange.Interior.ColorIndex
If EachTextColorIndex = 6 Then
EachHandle = WS.Cells(RNo, CNo - 5).Value
If EachHandle <> "" Then
EachText = WS.Cells(RNo, CNo).Value
EachUpdate = EachPath & Delimited & EachHandle & Delimited & EachText
ReDim Preserve UpdateArr(0 To aa)
UpdateArr(aa) = EachUpdate
aa = aa + 1
End If
End If
Next
GTSkip:
Next
If aa = 0 Then
GoTo GTES
Else
UpdateTotal = aa
End If
'Update
'Startup Cad Application
Dim AcadApp As AutoCAD.AcadApplication
Set AcadApp = JHF04_StartupAutoCad(AppValue)
Dim EachDrawing As AcadDocument
Dim EachSplit As Variant
Dim OldPath As String
Dim EachObjText As AcadText
Dim CountChange As Integer
For i = LBound(UpdateArr) To UBound(UpdateArr)
EachUpdate = UpdateArr(i)
EachSplit = Split(EachUpdate, Delimited)
EachPath = EachSplit(0)
EachHandle = EachSplit(1)
EachText = EachSplit(2)
'Open File(Write)
If EachPath <> OldPath Then
Set EachDrawing = JHF05_OpenCadFile_AutoCad(AcadApp, EachPath, False)
End If
'Change TextString
Set EachObjText = EachDrawing.HandleToObject(EachHandle)
If VarType(EachObjText) <> vbEmpty Then
EachObjText.TextString = EachText
CountChange = CountChange + 1
End If
OldPath = EachPath
Next
'Reset Color
Dim ResetColorRange As Range
Dim ResetRangeStr As String
ResetRangeStr = "C2:N" & EndRow
Set ResetColorRange = WS.Range(ResetRangeStr)
ResetColorRange.Interior.ColorIndex = 0
MsgBox "Updated " & CountChange & " / " & UpdateTotal
GTES:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function JHF01_CrearArrFromWSColumn(WS As Worksheet, MainColumnNo As Integer, RowFrom As Integer) As Variant
'Defaut Value
JHF01_CrearArrFromWSColumn = False
'Define EndRow
Dim EndRow As Integer
EndRow = WS.Cells(Rows.Count, MainColumnNo).End(xlUp).Row
If EndRow < RowFrom Then Exit Function
'Creat Arr
Dim Arr() As String: Dim aa As Integer
Dim RNo As Integer
Dim EachValue As String
For RNo = RowFrom To EndRow
EachValue = WS.Cells(RNo, MainColumnNo).Value
If EachValue <> "" Then
ReDim Preserve Arr(0 To aa)
Arr(aa) = EachValue
aa = aa + 1
End If
Next
'Result
If aa > 0 Then
JHF01_CrearArrFromWSColumn = Arr
End If
End Function
Function JHF02_Call_ClearDataCellFontColorOfRange(WS As Worksheet, ColumnFromLetter As String, ColumnToLetter As String, RowFrom As Integer)
'Define EndRow
Dim ColumnFromNo As Integer
Dim ColumnToNo As Integer
Dim EndRow As Integer
Dim EachEndRow As Integer
Dim CNo As Integer
ColumnFromNo = Func29ConvertColumnLetterToNumber(ColumnFromLetter)
ColumnToNo = Func29ConvertColumnLetterToNumber(ColumnToLetter)
For CNo = ColumnFromNo To ColumnToNo
Call HCF4079_DefineRowEndNo(WS, EachEndRow, CNo)
If EachEndRow > EndRow Then EndRow = EachEndRow
Next
If EndRow < RowFrom Then Exit Function
'Define ClearRangeStr
Dim ClearRangeStr As String
ClearRangeStr = ColumnFromLetter & RowFrom & ":" & ColumnToLetter & EndRow
'Define ClearRange
Dim ClearRange As Range
Set ClearRange = WS.Range(ClearRangeStr)
'Clear Old Data
ClearRange.ClearContents
'Clear Cell Color
With ClearRange.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Clear Font Color
With ClearRange.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
End Function
Function JHF03_DefineVersionAppValue(AutoCad_BricsCad As String, VersionNo As Integer) As Variant
'Defaut Value
JHF03_DefineVersionAppValue = False
'Define AppValue
Dim AppValue As String
Select Case AutoCad_BricsCad
Case "AutoCad"
Select Case VersionNo
Case 2014
Case 2015
Case 2016
Case 2017
Case 2018
Case 2019
AppValue = "AutoCAD.Application.23"
Case 2020
Case Else
Exit Function
End Select
Case "BricsCad"
Select Case VersionNo
Case 19
AppValue = "BricscadApp.AcadApplication"
Case 2020
Case Else
Exit Function
End Select
Case Else
Exit Function
End Select
'Result
If AppValue <> "" Then
JHF03_DefineVersionAppValue = AppValue
End If
End Function
Function JHF04_StartupAutoCad(AppValue As String) As AutoCAD.AcadApplication
On Error Resume Next
Dim AcadApp As AutoCAD.AcadApplication
Set AcadApp = GetObject(, AppValue)
If err Then
Set AcadApp = CreateObject(AppValue)
End If
AppActivate AcadApp.Caption
AcadApp.Visible = False
AcadApp.Application.WindowState = acNorm
AcadApp.ActiveDocument.ActiveSpace = acModelSpace
'Result
Set JHF04_StartupAutoCad = AcadApp
End Function
Function JHF05_OpenCadFile_AutoCad(AcadApp As AutoCAD.AcadApplication, FilePath As Variant, ReadOnlyMode As Boolean) As AcadDocument
Dim MyDrawing As AcadDocument
Dim EachDrawing As AcadDocument
Dim IsOpenning As Boolean
If AcadApp.Documents.Count > 0 Then
For Each EachDrawing In AcadApp.Documents
If EachDrawing.FullName = FilePath Then
IsOpenning = True
Set MyDrawing = EachDrawing
End If
Next
End If
Select Case ReadOnlyMode
Case True
If IsOpenning = False Then
Set MyDrawing = AcadApp.Documents.Open(FilePath, ReadOnlyMode)
End If
Case False
If IsOpenning = False Then
Set MyDrawing = AcadApp.Documents.Open(FilePath, ReadOnlyMode)
Else
MyDrawing.Close False
Set MyDrawing = AcadApp.Documents.Open(FilePath, ReadOnlyMode)
End If
End Select
'Result
Set JHF05_OpenCadFile_AutoCad = MyDrawing
End Function
Function JHF06X_Call_SelectLayoutContainWakuBlock(MyDrawing As AcadDocument, WakuBlockName As String)
Dim EachLayout As AcadLayout
Dim AllSelect As AcadSelectionSet
Set AllSelect = MyDrawing.SelectionSets.ADD("AllSelect" & Now)
Dim FT(0) As Integer: Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
For Each EachLayout In MyDrawing.Layouts
AllSelect.Select acSelectionSetAll, , , FT, FD
If AllSelect.Count <> 0 Then
AllSelect.Delete
MyDrawing.ActiveLayout = EachLayout
Exit Function
End If
Next
End Function
Function JHF07_SelectOnScreen(Thisdrawing As AcadDocument, SS As AcadSelectionSet, FilterData As String) As Boolean
Set SS = Thisdrawing.SelectionSets.ADD("SS" & Now)
Dim FT(0) As Integer: Dim FD(0) As Variant
FT(0) = 0: FD(0) = FilterData
SS.SelectOnScreen FT, FD
If SS.Count <> 0 Then
JHF07_SelectOnScreen = True
End If
End Function
Function JHF08_Call_MinMaxMiddleXYOfObject(Entity As AcadEntity, MinX As Double, MidX As Double, MaxX As Double, MinY As Double, MidY As Double, MaxY As Double, RoundMode As Integer)
'Define MinPoint, MaxPoint
Dim MinPoint As Variant
Dim MaxPoint As Variant
Entity.GetBoundingBox MinPoint, MaxPoint
'Define MinX,MaxX,MinY,MaxY
MinX = MinPoint(0)
MinY = MinPoint(1)
MaxX = MaxPoint(0)
MaxY = MaxPoint(1)
'Define MidX, MidY
MidX = (MinX + MaxX) / 2
MidY = (MinY + MaxY) / 2
'Round
If RoundMode <> 100 Then
MinX = Round(MinX, RoundMode)
MidX = Round(MidX, RoundMode)
MaxX = Round(MaxX, RoundMode)
MinY = Round(MinY, RoundMode)
MidY = Round(MidY, RoundMode)
MaxY = Round(MaxY, RoundMode)
End If
End Function
Function JHF09X_Call_WriteTextInfoToExcel(SS As AcadSelectionSet, ProcessWS As Worksheet)
'Define EndRow of ProcessWS
Dim EndRow As Integer
Dim WriteRow As Integer
Call HCF4079_DefineRowEndNo(ProcessWS, EndRow, 1)
WriteRow = EndRow + 1
'Define EachValue
Dim EachText As AcadText
Dim Each01Handle As String
Dim Each02TextString As String
Dim Each03MinX As Double
Dim Each04MidX As Double
Dim Each05MaxX As Double
Dim Each06MinY As Double
Dim Each07MidY As Double
Dim Each08MaxY As Double
Dim Each09Len As Double
Dim Each10Height As Double
For Each EachText In SS
Each01Handle = EachText.Handle
'Reform TextString
Each02TextString = EachText.TextString
Each02TextString = JHF10X_ReFormTextString(Each02TextString)
If Each02TextString = "" Then GoTo GTSkip
Call JHF08_Call_MinMaxMiddleXYOfObject(EachText, Each03MinX, Each04MidX, Each05MaxX, Each06MinY, Each07MidY, Each08MaxY, 1)
Each09Len = Each05MaxX - Each03MinX
Each10Height = EachText.Height
Each10Height = Round(Each10Height, 1)
'Write EachVale to Excel
ProcessWS.Cells(WriteRow, 1).Value = Each01Handle
ProcessWS.Cells(WriteRow, 2).Value = Each02TextString
ProcessWS.Cells(WriteRow, 3).Value = Each03MinX
ProcessWS.Cells(WriteRow, 4).Value = Each04MidX
ProcessWS.Cells(WriteRow, 5).Value = Each05MaxX
ProcessWS.Cells(WriteRow, 6).Value = Each06MinY
ProcessWS.Cells(WriteRow, 7).Value = Each07MidY
ProcessWS.Cells(WriteRow, 8).Value = Each08MaxY
ProcessWS.Cells(WriteRow, 9).Value = Each09Len
ProcessWS.Cells(WriteRow, 10).Value = Each10Height
WriteRow = WriteRow + 1
GTSkip:
Next
End Function
Function JHF10X_ReFormTextString(BeforeValue As String) As String
'Check Input
If BeforeValue = "" Then Exit Function
'Convert JIS to ASC
Dim AfterValue As String
AfterValue = WorksheetFunction.Asc(BeforeValue)
'Clear Space
AfterValue = WorksheetFunction.Substitute(AfterValue, " ", "")
'Check is in IgoreTextArr
Dim IsInIgoreList As Boolean
If VarType(IgoreTextList) = vbBoolean Then
JHF10X_ReFormTextString = AfterValue
Exit Function
Else
IsInIgoreList = HCF4086_IsInArr1Chieu_NumberOrString(IgoreTextList, AfterValue)
End If
If IsInIgoreList = True Then
JHF10X_ReFormTextString = ""
Else
JHF10X_ReFormTextString = AfterValue
End If
End Function
Function JHF11_DefineMinMaxValueAndPosition_IgoreColorIndex(WS As Worksheet, ColorIndex As Integer, CNo As Integer, RFrom As Integer, RTo As Integer, MinMaxMode As String, ResultValue As Double, ResultRNo As Integer) As Boolean
'Gan MinValue, MaxValue
Dim MinValue As Double
Dim MaxValue As Double
Dim RNo As Integer
Dim EachValue As Double
Dim EachColorIndex As Integer
Dim EachCell As Range
Dim DefineMinMax As Boolean
For RNo = RFrom To RTo
Set EachCell = WS.Cells(RNo, CNo)
EachColorIndex = EachCell.Interior.ColorIndex
If ColorIndex <> EachColorIndex Then
EachValue = EachCell.Value
MinValue = EachValue
MaxValue = EachValue
DefineMinMax = True
GoTo GTNextStep
End If
Next
GTNextStep:
If DefineMinMax = False Then
Exit Function
End If
'Compare CellValue with Min,Max
Dim MinRNoPosition As Integer
Dim MaxRNoPosition As Integer
For RNo = RFrom To RTo
Set EachCell = WS.Cells(RNo, CNo)
EachColorIndex = EachCell.Interior.ColorIndex
If ColorIndex <> EachColorIndex Then
EachValue = EachCell.Value
If EachValue <= MinValue Then
MinValue = EachValue
MinRNoPosition = RNo
End If
If EachValue >= MaxValue Then
MaxValue = EachValue
MaxRNoPosition = RNo
End If
End If
Next
'Result
Select Case MinMaxMode
Case "Min"
ResultValue = MinValue
ResultRNo = MinRNoPosition
Case "Max"
ResultValue = MaxValue
ResultRNo = MaxRNoPosition
End Select
JHF11_DefineMinMaxValueAndPosition_IgoreColorIndex = True
End Function
Function JHF12_CompareValueWithMinMax_IgoreColorIndex(WS As Worksheet, ColorIndex As Integer, RNo As Integer, CNo As Integer, MinValue As Double, MaxValue As Double) As Boolean
'Compare CellValue with Min,Max
Dim EachCell As Range
Dim EachColorIndex As Integer
Dim EachValue As Double
Set EachCell = WS.Cells(RNo, CNo)
EachColorIndex = EachCell.Interior.ColorIndex
If EachColorIndex <> ColorIndex Then
EachValue = EachCell.Value
If MinValue <= EachValue And EachValue <= MaxValue Then
JHF12_CompareValueWithMinMax_IgoreColorIndex = True
End If
End If
End Function
Function JHF13_CreatListValueAndSort_NumberType(WS As Worksheet, ColumnNo As Integer, RFrom As Integer, SortAtoZ_SortZtoA_NoSort As String) As Variant
'Define EndRow
Dim EndRow As Integer
EndRow = WS.Cells(Rows.Count, ColumnNo).End(xlUp).Row
'Creat ValueArr
Dim ValueArr() As Variant
Dim aa As Integer: aa = 1
Dim RNo As Integer
Dim EachValue As Double
Dim IsInArr As Boolean
For RNo = RFrom To EndRow
EachValue = WS.Cells(RNo, ColumnNo).Value
If aa = 1 Then
IsInArr = False
Else
IsInArr = HCF4086_IsInArr1Chieu_NumberOrString(ValueArr, EachValue)
End If
If IsInArr = False Then
ReDim Preserve ValueArr(1 To aa)
ValueArr(aa) = EachValue
aa = aa + 1
End If
Next
If aa = 1 Then
JHF13_CreatListValueAndSort_NumberType = False
Exit Function
End If
'Sort
Select Case SortAtoZ_SortZtoA_NoSort
Case "SortAtoZ"
ValueArr = HCF4057_SortArrAtoZ_NumberType(ValueArr)
Case "SortZtoA"
ValueArr = JHF14_SortArrZtoA_NumberType(ValueArr)
Case Else
End Select
'Resutl
JHF13_CreatListValueAndSort_NumberType = ValueArr
End Function
Function JHF14_SortArrZtoA_NumberType(Arr As Variant) As Variant
Dim BackupValue As Double
Dim CompareValue As Double
Dim EachValue As Double
Dim TmpArr As Variant
TmpArr = Arr
For i = LBound(TmpArr) To UBound(TmpArr)
CompareValue = TmpArr(i)
For k = i To UBound(TmpArr)
EachValue = TmpArr(k)
If CompareValue < EachValue Then
BackupValue = CompareValue
CompareValue = EachValue
EachValue = BackupValue
TmpArr(i) = CompareValue
TmpArr(k) = EachValue
End If
Next
Next
JHF14_SortArrZtoA_NumberType = TmpArr
End Function
Function JHF15X_WriteTableRNoCNoToProcessWS(WS As Worksheet, ValueList As Variant, ValueCNo As Integer, WriteCNo As Integer, RFrom As Integer, RTo As Integer)
Dim RNo As Integer
Dim EachValue As Double
Dim EachTableRCNo As Variant
For RNo = RFrom To RTo
EachValue = WS.Cells(RNo, ValueCNo).Value
EachTableRCNo = HCF4158_DefinePositionInArr1ChieuWithDelta_Number(ValueList, EachValue, 0)
If VarType(EachTableRCNo) <> vbBoolean Then
WS.Cells(RNo, WriteCNo).Value = EachTableRCNo
End If
Next
End Function
Function JHF16_MinMaxValueAtColumnOfWS(WS As Worksheet, CNo As Integer, MinOrMax As String) As Double
'Define ValueRange
Dim ValueRange As Range
Set ValueRange = WS.Columns(CNo)
'Define MinValue MaxValue
Dim MinValue As Double
Dim MaxVale As Double
MinValue = WorksheetFunction.Min(ValueRange)
MaxValue = WorksheetFunction.Max(ValueRange)
'Result
Select Case MinOrMax
Case "Min"
JHF16_MinMaxValueAtColumnOfWS = MinValue
Case "Max"
JHF16_MinMaxValueAtColumnOfWS = MaxValue
Case Else
MsgBox "Err: Check value of MinOrMax in function"
End Select
End Function
Function JHF17X_CreatTableVale(WS As Worksheet, Table() As String, ValueColumnNo As Integer, RFrom As Integer, RTo As Integer) As Boolean
'Defaut Value
JHF17X_CreatTableVale = False
'Process
Dim RNo As Integer
Dim EachValue As String
Dim EachTableRNo As Integer
Dim EachTableCNo As Integer
Dim EachOldValue As String
For RNo = RFrom To RTo
EachValue = WS.Cells(RNo, ValueColumnNo).Value
EachTableRNo = WS.Cells(RNo, 11).Value
EachTableCNo = WS.Cells(RNo, 12).Value
EachOldValue = Table(EachTableRNo, EachTableCNo)
If EachOldValue <> "" Then
MsgBox "Err: Duplication TableRNo,TableCNo"
Exit Function
Else
Table(EachTableRNo, EachTableCNo) = EachValue
End If
Next
'Function Result
JHF17X_CreatTableVale = True
End Function
Function JHF18_DefineEndRowOfRange(WS As Worksheet, ColumnFromLetter As String, ColumnToLetter As String) As Integer
'Define ColumnFromNo, ColumnToNo
Dim ColumnFromNo As Integer
Dim ColumnToNo As Integer
ColumnFromNo = Func29ConvertColumnLetterToNumber(ColumnFromLetter)
ColumnToNo = Func29ConvertColumnLetterToNumber(ColumnToLetter)
'Define EndRow
Dim EndRow As Integer
Dim EachEndRow As Integer
Dim CNo As Integer
For CNo = ColumnFromNo To ColumnToNo
Call HCF4079_DefineRowEndNo(WS, EachEndRow, CNo)
If EachEndRow > EndRow Then EndRow = EachEndRow
Next
'Function Result
JHF18_DefineEndRowOfRange = EndRow
End Function
Function JHF19_Call_MsgBox_SelectMode(ButtonMode As VbMsgBoxStyle, MsgMain As String, MsgYes As String, MsgNo As String, MsgCancel As String, Response As VbMsgBoxResult)
Dim MsgTitle As String: MsgTitle = "(TB VBABoss)"
'Define Msg
Dim Msg As String
Select Case ButtonMode
Case vbYesNo
Msg = MsgMain & vbNewLine & vbNewLine & _
Space(5) & "Yes: " & MsgYes & vbNewLine & _
Space(5) & "No: " & MsgNo
Case vbYesNoCancel
Msg = MsgMain & vbNewLine & vbNewLine & _
Space(5) & "Yes: " & MsgYes & vbNewLine & _
Space(5) & "No: " & MsgNo & vbNewLine & _
Space(5) & "Cancel: " & MsgCancel
Case Else
Exit Function
End Select
Response = MsgBox(Msg, ButtonMode, MsgTitle)
End Function
Function JHF20_Call_DefineRFromRToCFromCToOfRange(TargetRange As Range, RRFrom As Integer, RRTo As Integer, RCFrom As Integer, RCTo As Integer)
'Define FirstCell, EndCell
Dim FirstCell As Range
Dim EndCell As Range
Set FirstCell = TargetRange.Cells(1, 1)
Set EndCell = TargetRange.Cells(TargetRange.Rows.Count, TargetRange.Columns.Count)
'Define RRFrom RRTo RCFrom RCTo
RRFrom = FirstCell.Row
RRTo = EndCell.Row
RCFrom = FirstCell.Column
RCTo = EndCell.Column
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Func29ConvertColumnLetterToNumber(ColumnLetter As String) As Integer
' Function chuyen ma so cot tu letter sang number
'Convert To Column Number
Dim ColumnNumber As Long
ColumnNumber = Range(ColumnLetter & 1).Column
Func29ConvertColumnLetterToNumber = ColumnNumber
End Function
Function HCF4079_DefineRowEndNo(WS As Worksheet, EndRow As Integer, ColumnNo As Integer)
EndRow = WS.Cells(Rows.Count, ColumnNo).End(xlUp).Row
End Function
Function HCF4086_IsInArr1Chieu_NumberOrString(ListArr As Variant, NeedCheckValue As Variant) As Boolean
Dim CompareValue As Variant
For i = LBound(ListArr) To UBound(ListArr)
CompareValue = ListArr(i)
If CompareValue = NeedCheckValue Then
HCF4086_IsInArr1Chieu_NumberOrString = True
Exit Function
End If
Next
End Function
Function Func17BSetCellColorIndex(WS As Worksheet, RowNo As Integer, ColumnNoFrom As Integer, ColumnNoTo As Integer, ColorIndex As Integer)
' to mau cho o voi colorindex
For i = ColumnNoFrom To ColumnNoTo
With WS.Cells(RowNo, i).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ColorIndex = ColorIndex
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Next
End Function
Function HCF4057_SortArrAtoZ_NumberType(Arr As Variant) As Variant
' Sap xep cac phan tu cua mang theo thu tu tu A den Z
Dim TmpValue As Double
Dim SmallValue As Double
Dim LargeValue As Double
Dim TmpArr As Variant
TmpArr = Arr
For i = LBound(TmpArr) To UBound(TmpArr)
SmallValue = TmpArr(i)
For k = i To UBound(TmpArr)
LargeValue = TmpArr(k)
If SmallValue > LargeValue Then
TmpValue = SmallValue
SmallValue = LargeValue
LargeValue = TmpValue
TmpArr(i) = SmallValue
TmpArr(k) = LargeValue
End If
Next
Next
HCF4057_SortArrAtoZ_NumberType = TmpArr
End Function
Function HCF4158_DefinePositionInArr1ChieuWithDelta_Number(ListArr As Variant, NeedCheckValue As Double, Delta As Double) As Variant
'Defaut Value
HCF4158_DefinePositionInArr1ChieuWithDelta_Number = False
'Process
Dim CompareValue As Variant
For i = LBound(ListArr) To UBound(ListArr)
CompareValue = ListArr(i)
CompareValue = CDbl(CompareValue)
If Abs(CompareValue - NeedCheckValue) <= Delta Then
HCF4158_DefinePositionInArr1ChieuWithDelta_Number = i
Exit Function
End If
Next
End Function
Function After_(Txt As String, Delimiter As String) As String
Dim DelimiterPosition As Integer
DelimiterPosition = InStr(Txt, Delimiter)
After_ = Right(Txt, Len(Txt) - DelimiterPosition)
End Function
Function Before_(Txt As String, Delimiter As String) As String
Dim DelimiterPosition As Integer
DelimiterPosition = InStr(Txt, Delimiter)
Before_ = Left(Txt, DelimiterPosition - 1)
End Function
