Reply to Message

View discussion in a popup

Replying to:

Sub TH0202AutomaticPrint()

'Chon doi tuong bang select on screen
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)

Dim FT(3) As Integer
Dim FD(3) As Variant
FT(0) = -4: FD(0) = "<AND"
FT(1) = 0: FD(1) = "LWPolyline"
FT(2) = 8: FD(2) = "04_HIDDEN"
FT(3) = -4: FD(3) = "AND>"

objSelectOnScreen.Select acSelectionSetAll, , , FT, FD
If objSelectOnScreen.count = 0 Then Exit Sub

Dim ThisPlot As AcadPlot
Set ThisPlot = Thisdrawing.Plot

Dim temp As Variant
'Set so to can in
ThisPlot.NumberOfCopies = 1
ThisPlot.QuietErrorMode = True
Dim Thislayout As AcadLayout
Set Thislayout = Thisdrawing.ActiveLayout


Thislayout.ConfigName = "Adobe PDF.pc3" 'Plot device
Thislayout.CanonicalMediaName = "A3" 'Paper Size
Thislayout.CenterPlot = True 'Center the plot
Thislayout.StandardScale = acScaleToFit 'Scale to fit
Thislayout.PaperUnits = acMillimeters 'Paper unit is mm
Thislayout.PlotHidden = False 'N/A
Thislayout.PlotRotation = ac90degrees 'in nam ngang

Thislayout.StyleSheet = "monochrome.ctb" 'Plot style
Thislayout.PlotWithLineweights = True
Thislayout.PlotWithPlotStyles = True

Dim EachobjSelectOnScreen As AcadEntity
Dim MinPoint, MaxPoint As Variant

For Each EachobjSelectOnScreen In objSelectOnScreen
EachobjSelectOnScreen.GetBoundingBox MinPoint, MaxPoint
'translate the points which are in World UCS to Display coordinates
MinPoint = Thisdrawing.Utility.TranslateCoordinates(MinPoint, acWorld, acDisplayDCS, False)
MaxPoint = Thisdrawing.Utility.TranslateCoordinates(MaxPoint, acWorld, acDisplayDCS, False)
ReDim Preserve MinPoint(0 To 1)
ReDim Preserve MaxPoint(0 To 1)
Thislayout.SetWindowToPlot MinPoint, MaxPoint
Thislayout.PlotType = acWindow 'Print by Window
ThisPlot.PlotToDevice
Next
objSelectOnScreen.Delete


End Sub


Function Func15ACopyFileFollowLArr(FilesList As Variant, CopyFileList As Variant, CopyToFolderPath As String, WS As Worksheet, RefColumn As Integer, RefEndRow As Integer) As Integer
'Kiem tra trong cac phan tu cua mang ListText, co phan tu nao nam trong SearchInText hay khong

Dim File As Variant
Dim NeedCopyFilename As String
Dim NeedCopyFullFilename As String
Dim FilePath As String
Dim CopyFilePath As String
Dim FileName As String
Dim CopiedFileCount As Integer

For i = LBound(CopyFileList) To UBound(CopyFileList)
NeedCopyFilename = CopyFileList(i)
CopyFilePath = ""
For Each File In FilesList
'Lay file name, dinh dang aaaaa-bbb
FilePath = File
FileName = Func05CreatFilenameFromPath(FilePath, "FileName")
'Kiem tra xem text filename co trong NeedCopyFilename hay khong
If InStr(FileName, NeedCopyFilename) <> 0 Then 'neu co file
If StrComp(FileName, NeedCopyFullFilename) >= 0 Then
CopyFilePath = FilePath
NeedCopyFullFilename = FileName
End If
End If
Next
If CopyFilePath <> "" Then
Call Func14CopyFileFromFilePathToFolder(CopyFilePath, NeedCopyFullFilename, CopyToFolderPath)
CopiedFileCount = CopiedFileCount + 1
'Viet Ï vao excel
For k = 3 To RefEndRow
If WS.Cells(k, RefColumn).Value = NeedCopyFilename Then
WS.Cells(k, RefColumn).Value = NeedCopyFullFilename
WS.Cells(k, RefColumn + 1).Value = "Ï"
End If
Next
End If
Next
Func15ACopyFileFollowLArr = CopiedFileCount
End Function