图案填充和UCS原点

Dim Pnt1 As Variant
Dim Pnt2 As Variant
Dim XAx(2) As Double
Dim YAx(2) As Double
'Get the bounding box
HatchObj.GetBoundingBox Pnt1, Pnt2
'Get the current UCS so we can reset it
Set UCSOrg = ThisDrawing.ActiveUCS
'Set the direction vectors of the temp UCS
XAx(0) = Pnt1(0): XAx(1) = 0#: XAx(2) = 0#
YAx(0) = 0#: YAx(1) = Pnt1(1): YAx(2) = 0#
'Create a new UCS
Set NewUCS = ThisDrawing.UserCoordinateSystems.Add(Pnt1, XAx, YAx, "temp")
'Set it active
ThisDrawing.ActiveUCS = NewUCS
'Evaluate the hatch --- this should reset the hatch based upon the current UCS, but it doesn't
HatchObj.Evaluate
'Update the object
HatchObj.UpDate
'Reset the previous UCS
ThisDrawing.ActiveUCS = UCSOrg
'Remove our temp UCS
ThisDrawing.UserCoordinateSystems.Item("temp").Delete

'Get the hatch
    Set HatchObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
'and the bounding box
    HatchObj.GetBoundingBox Pnt1, Pnt2
'create new UCS
    Set UCSOrg = ThisDrawing.ActiveUCS
'set the vectors
    XAx(0) = Pnt1(0) + 12: XAx(1) = Pnt1(1): XAx(2) = 0#
    YAx(0) = Pnt1(0): YAx(1) = Pnt1(1) + 12: YAx(2) = 0#
'set the new UCS
    Set NewUCS = ThisDrawing.UserCoordinateSystems.Add(Pnt1, XAx, YAx, "temp")
    ThisDrawing.ActiveUCS = NewUCS
'set a constant scale (we can change this to what is needed)
    HatchObj.PatternScale = 48
'make the pattern angle 
    HatchObj.PatternAngle = Int((48 * Rnd) + 1)
'assign the changes
    HatchObj.Evaluate
'update the object
    HatchObj.UpDate
'reset the origin
    ThisDrawing.ActiveUCS = UCSOrg
'delete the temp origin
    ThisDrawing.UserCoordinateSystems.Item("temp").Delete

'Get the hatch
    Set HatchObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
'and the bounding box
    HatchObj.GetBoundingBox Pnt1, Pnt2
'create new UCS
   If ThisDrawing.GetVariable("WORLDUCS") = 1 Then
    With ThisDrawing
    Set UCSOrg = .UserCoordinateSystems.Add( _
    .GetVariable("UCSORG"), _
    .Utility.TranslateCoordinates(.GetVariable("UCSXDIR"), acUCS, acWorld, 0), _
    .Utility.TranslateCoordinates(.GetVariable("UCSYDIR"), acUCS, acWorld, 0), _
    "whirled")
    End With
    Else
    Set UCSOrg = ThisDrawing.ActiveUCS
    End If
'set the vectors
    XAx(0) = Pnt1(0) + 12: XAx(1) = Pnt1(1): XAx(2) = 0#
    YAx(0) = Pnt1(0): YAx(1) = Pnt1(1) + 12: YAx(2) = 0#
'set the new UCS
    Set NewUCS = ThisDrawing.UserCoordinateSystems.Add(Pnt1, XAx, YAx, "temp")
    ThisDrawing.ActiveUCS = NewUCS
'set a constant scale (we can change this to what is needed)
    HatchObj.PatternScale = 48
'make the pattern angle 
    HatchObj.PatternAngle = Int((48 * Rnd) + 1)
'assign the changes
    HatchObj.Evaluate
'update the object
    HatchObj.UpDate
'reset the origin
    ThisDrawing.ActiveUCS = UCSOrg
'delete the temp origin
    ThisDrawing.UserCoordinateSystems.Item("temp").Delete

Sub test()
Dim AUcs As AcadUCS
Dim WorldUCS As AcadUCS
Dim NewUCS As AcadUCS
Dim orig(2) As Double
Dim vx(2) As Double
Dim vy(2) As Double
Dim hatchObj As AcadHatch
Dim Pnt1(2) As Double
Dim Pnt2(2) As Double
Set AUcs = ThisDrawing.ActiveUCS
With AUcs
vx(0) = .XVector(0): vx(1) = .XVector(1): vx(2) = .XVector(2)
vy(0) = .YVector(0): vy(1) = .YVector(1): vy(2) = .YVector(2)
orig(0) = .Origin(0): orig(1) = .Origin(1): orig(2) = .Origin(2)
End With
'' just to inform , perhaps extrafluous here
If vx(0) = 1# And vx(1) = 0# And vx(2) = 0# And _
   vy(0) = 0# And vy(1) = 1# And vy(2) = 0# And _
   orig(0) = 0# And orig(1) = 0# And orig(2) = 0# Then
Debug.Print "World UCS"
Set WorldUCS = ThisDrawing.UserCoordinateSystems.Add(orig, vx, vy, "WorldUCS")
Else
orig(0) = 0#: orig(1) = 0#: orig(2) = 0#
vx(0) = 1#: vx(1) = 0#: vx(2) = 0
vy(0) = 0#: vy(1) = 1#: vy(2) = 0#
Set WorldUCS = ThisDrawing.UserCoordinateSystems.Add(orig, vx, vy, "WorldUCS")
End If
''Get the hatch
    Set hatchObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
''and the bounding box
    hatchObj.GetBoundingBox Pnt1, Pnt2
'create new UCS
    'Set UCSOrg = ThisDrawing.ActiveUCS 'you are already there
'set the vectors
    vx(0) = Pnt1(0) + 12: vx(1) = Pnt1(1): vx(2) = 0#
    vy(0) = Pnt1(0): vy(1) = Pnt1(1) + 12: vy(2) = 0#
'set the new UCS
    Set NewUCS = ThisDrawing.UserCoordinateSystems.Add(Pnt1, vx, vy, "temp")
    ThisDrawing.ActiveUCS = NewUCS
'set a constant scale (we can change this to what is needed)
    hatchObj.PatternScale = 48
'make the pattern angle
    hatchObj.PatternAngle = Int((48 * Rnd) + 1)
'assign the changes
    hatchObj.Evaluate
'update the object
    hatchObj.Update
'reset the origin
    ThisDrawing.ActiveUCS = WorldUCS
'delete the temp origin
    ThisDrawing.UserCoordinateSystems.Item("temp").Delete
End Sub