KHTMFile 💾

Sub CopyCurveLengthToText()
    Dim s As Shape
    Dim t As Shape
    Dim lengthVal As Double
    
    
    Dim OrigSelection As ShapeRange
    Set OrigSelection = ActiveSelectionRange
    OrigSelection.ConvertToCurves
    
    ' Check if there is an active selection
    If ActiveShape Is Nothing Then
        MsgBox "Please select a curve first!", vbExclamation
        Exit Sub
    End If
    
    Set s = ActiveShape
    
    ' Check if the selected shape is a curve
    If s.Type = cdrCurveShape Then
        ' Calculate curve length (VBA default is Inches, so multiply by 2.54 for cm)
        lengthVal = s.Curve.Length * 2.54
        
        ' Create Artistic Text with 4 decimal places
        Set t = ActiveLayer.CreateArtisticText(0, 0, "Length: " & Round(lengthVal, 4) & " cm")
        
        ' Align text to the center of the selection
        t.CenterX = s.CenterX
        
        ' Position the text slightly above the curve
        t.CenterY = s.CenterY + 1
        
        ' Set text color to Red for visibility
'        t.Fill.UniformColor.SetRGB 255, 0, 0
    Else
        MsgBox "The selected object is not a curve.", vbCritical
    End If
End Sub

590 views10:08

KHTMFile 💾

ក្នុងឱកាសពិធីបុណ្យចូលឆ្នាំថ្មីប្រពៃណីជាតិខ្មែរ
ខាងខ្ញុំបានឈប់សម្រាក ចំនួន ៥ ថ្ងៃ
ចាប់ពីថ្ងៃទី១២ ដល់ ១៦ ខែមេសា ឆ្នាំ២០២៦។
នឹងចូលបម្រើការងារនូវថ្ងៃទី១៧ ខែមេសា ឆ្នាំ២០២៦ ជាធម្មតា។
យើងខ្ញុំសូមថ្លែងអំណរអរគុណយ៉ាងជ្រាលជ្រៅដល់អតិថិជនទាំងអស់
ដែលបានគាំទ្រខាងយើងខ្ញុំកន្លងមក និងបន្តគាំទ្រជានិច្ចកាល។

សូមជូនពរអតិថិជនទាំងអស់អោយ រកទទួលទានមានបាន និងជួបតែពុទ្ធពរ ៤ប្រការ អាយុ វណ្ណ សុខ និង ពល រកស៊ីដាក់ដុះកើនទ្រព្យគ្រប់ៗពេល។

យើងខ្ញុំសូមខន្ដីអភ័យទោសចំពោះការឆ្លើយតបដោយមានការយឺតយ៉ាវកន្លងមក សូមអភ័យទោស និងអរគុណទុកជាមុន។

529 views05:12

KHTMFile 💾

សម្រាប់ការងារបង្ហាញម៉ែត្រ

ActiveDocument.Rulers.HUnits

ActiveDocument.Unit

554 views05:18

KHTMFile 💾

https://freeonekh.blogspot.com/2023/01/free-tif.html

Free One kh

វិសាខបូជា-Free-Tif

{getProduct} $button={Download Now} $price={Free} $free={yes} $icon={download}

467 views11:59

KHTMFile 💾

KHTMFile 💾 pinned «https://freeonekh.blogspot.com/2023/01/free-tif.html»

12:54

KHTMFile 💾

Sub RenamePagesFromTextBulk()

Dim doc As Document
Dim pg As Page
Dim shp As Shape
Dim txt As String
Dim i As Integer

Dim invalidChars As String
Dim regex As Object

If Documents.Count = 0 Then
MsgBox "Нет открытого документа.", vbExclamation, "Ошибка"
Exit Sub
End If

Set doc = ActiveDocument

invalidChars = "\/:*?""<>|"

Set regex = CreateObject("VBScript.RegExp")
regex.Pattern = "[\/:*?""<>|]"
regex.Global = True

For Each pg In doc.Pages

txt = ""

' Переключаемся на страницу
pg.Activate

' Ищем первый текстовый объект на странице
For i = 1 To ActivePage.Shapes.Count
Set shp = ActivePage.Shapes(i)

If shp.Type = cdrTextShape Then
txt = shp.Text.Story.Text
Exit For
End If

Next i

txt = Trim(txt)

If Len(txt) = 0 Then
' нет текста — пропускаем страницу
GoTo NextPage
End If

' нормализация текста
txt = Replace(txt, vbCrLf, " ")
txt = Replace(txt, vbCr, " ")
txt = Replace(txt, vbLf, " ")

txt = regex.Replace(txt, "")
txt = Trim(txt)

If Len(txt) > 31 Then txt = Left(txt, 31)

If Len(txt) = 0 Then GoTo NextPage

' защита от дублей
txt = MakeUniquePageName(doc, txt)

On Error Resume Next
pg.Name = txt
On Error GoTo 0

NextPage:
Next pg

MsgBox "Переименование страниц завершено.", vbInformation

End Sub

Function MakeUniquePageName(doc As Document, baseName As String) As String

Dim nameTry As String
Dim counter As Integer
Dim p As Page
Dim exists As Boolean

nameTry = baseName
counter = 1

Do
exists = False

For Each p In doc.Pages
If p.Name = nameTry Then
exists = True
Exit For
End If
Next p

If Not exists Then Exit Do

nameTry = baseName & "_" & counter
counter = counter + 1

Loop

MakeUniquePageName = nameTry

End Function

454 views12:54