Excel表格到CAD(VBA).txt
- 文档编号:7625617
- 上传时间:2023-05-11
- 格式:TXT
- 页数:6
- 大小:8.21KB
Excel表格到CAD(VBA).txt
《Excel表格到CAD(VBA).txt》由会员分享,可在线阅读,更多相关《Excel表格到CAD(VBA).txt(6页珍藏版)》请在冰点文库上搜索。
SubTest()
OnErrorResumeNext
'����ExcelӦ�ó���
DimxlAppAsExcel.Application
SetxlApp=GetObject(,"Excel.Application")
IfErrThen
MsgBox"ExcelӦ�ó���û�����С������Excel���������г���"
ExitSub
EndIf
DimxlSheetAsWorksheet
SetxlSheet=xlApp.ActiveSheet
'�������ǽ�������ɿ�ķ�ʽ�����Ը�����Ҫȡ�ᡣ
'DimiPt(0To2)AsDouble
'iPt(0)=0:
iPt
(1)=0:
iPt
(2)=0
DimBlockObjAsAcadBlock
SetBlockObj=ThisDrawing.Blocks("*Model_Space")
DimiPtAsVariant
iPt=ThisDrawing.Utility.GetPoint(,"ָ�����IJ����:
")
IfIsEmpty(iPt)ThenExitSub
DimxlRangeAsRange
Debug.PrintxlSheet.UsedRange.Address
ForEachxlRangeInxlSheet.UsedRange
AddLineBlockObj,iPt,xlRange
AddTextBlockObj,iPt,xlRange
Next
SetxlRange=Nothing
SetxlSheet=Nothing
SetxlApp=Nothing
EndSub
'�߿�������ϸ
FunctionLineWidth(ByValxlBorderAsBorder)AsDouble
SelectCasexlBorder.Weight
CasexlThin
LineWidth=0
CasexlMedium
LineWidth=0.35
CasexlThick
LineWidth=0.7
CaseElse
LineWidth=0
EndSelect
EndFunction
'�߿�������ɫ���������ɫ��ȫ�����Լ����
FunctionLineColor(ByValxlBorderAsBorder)AsInteger
SelectCasexlBorder.ColorIndex
CasexlAutomatic
LineColor=acByLayer
Case3
LineColor=acRed
Case4
LineColor=acGreen
Case5
LineColor=acBlue
Case6
LineColor=acYellow
Case8
LineColor=acCyan
Case9
LineColor=acMagenta
CaseElse
LineColor=acByLayer
EndSelect
EndFunction
'���Ʊ߿�
SubAddLine(ByRefBlockObjAsAcadBlock,ByValiPtAsVariant,ByValxlRangeAsRange)
IfxlRange.Borders(xlEdgeLeft).LineStyle=xlNone_
AndxlRange.Borders(xlEdgeBottom).LineStyle=xlNone_
AndxlRange.Borders(xlEdgeRight).LineStyle=xlNone_
AndxlRange.Borders(xlEdgeTop).LineStyle=xlNoneThenExitSub
DimrlAsDouble
DimrtAsDouble
DimrwAsDouble
DimrhAsDouble
rl=PToM(xlRange.Left)
rt=PToM(xlRange.top)
rw=PToM(xlRange.Width)
rh=PToM(xlRange.Height)
DimpPt(0To3)AsDouble
DimpLineObjAsAcadLWPolyline
'��߿�Ĵ��������һ�в��������
IfxlRange.Borders(xlEdgeLeft).LineStyle<>xlNoneAndxlRange.Column=1Then
pPt(0)=iPt(0)+rl:
pPt
(1)=iPt
(1)-rt
pPt
(2)=iPt(0)+rl:
pPt(3)=iPt
(1)-(rt+rh)
SetpLineObj=BlockObj.AddLightWeightPolyline(pPt)
pLineObj.ConstantWidth=LineWidth(xlRange.Borders(xlEdgeLeft))
pLineObj.Color=LineColor(xlRange.Borders(xlEdgeLeft))
EndIf
'�±߿�Ĵ�������ںϲ���Ԫ��ֻ�������һ�С�
IfxlRange.Borders(xlEdgeBottom).LineStyle<>xlNoneAnd(xlRange.Row=xlRange.MergeArea.Row+xlRange.MergeArea.Rows.Count-1)Then
pPt(0)=iPt(0)+rl:
pPt
(1)=iPt
(1)-(rt+rh)
pPt
(2)=iPt(0)+rl+rw:
pPt(3)=iPt
(1)-(rt+rh)
SetpLineObj=BlockObj.AddLightWeightPolyline(pPt)
pLineObj.ConstantWidth=LineWidth(xlRange.Borders(xlEdgeBottom))
pLineObj.Color=LineColor(xlRange.Borders(xlEdgeBottom))
EndIf
'�ұ߿�Ĵ�������ںϲ���Ԫ��ֻ�������һ�С�
IfxlRange.Borders(xlEdgeRight).LineStyle<>xlNoneAnd(xlRange.Column>=xlRange.MergeArea.Column+xlRange.MergeArea.Columns.Count-1)Then
pPt(0)=iPt(0)+rl+rw:
pPt
(1)=iPt
(1)-(rt+rh)
pPt
(2)=iPt(0)+rl+rw:
pPt(3)=iPt
(1)-rt
SetpLineObj=BlockObj.AddLightWeightPolyline(pPt)
pLineObj.ConstantWidth=LineWidth(xlRange.Borders(xlEdgeRight))
pLineObj.Color=LineColor(xlRange.Borders(xlEdgeRight))
EndIf
'�ϱ߿�Ĵ��������һ�в��������
IfxlRange.Borders(xlEdgeTop).LineStyle<>xlNoneAndxlRange.Row=1Then
pPt(0)=iPt(0)+rl+rw:
pPt
(1)=iPt
(1)-rt
pPt
(2)=iPt(0)+rl:
pPt(3)=iPt
(1)-rt
SetpLineObj=BlockObj.AddLightWeightPolyline(pPt)
pLineObj.ConstantWidth=LineWidth(xlRange.Borders(xlEdgeTop))
pLineObj.Color=LineColor(xlRange.Borders(xlEdgeTop))
EndIf
SetpLineObj=Nothing
EndSub
'�����ı�
SubAddText(ByRefBlockObjAsAcadBlock,ByValInsertionPointAsVariant,ByValxlRangeAsRange)
IfxlRange.Text=""ThenExitSub
DimrlAsDouble
DimrtAsDouble
DimrwAsDouble
DimrhAsDouble
rl=PToM(xlRange.Left)
rt=PToM(xlRange.top)
rw=PToM(xlRange.MergeArea.Width)
rh=PToM(xlRange.MergeArea.Height)
DimiAsInteger
DimsAsString
Fori=1ToLen(xlRange.Text)'��EXCEL�Ļ��з��滻��\P��ע�������R2002���Ͽ�ʹ��Replace������
IfAsc(Mid(xlRange.Text,i,1))=10Then
s=s&"\P"
Else
s=s&Mid(xlRange.Text,i,1)
EndIf
Next
DimiPt(0To2)AsDouble
iPt(0)=InsertionPoint(0)+rl:
iPt
(1)=InsertionPoint
(1)-rt:
iPt
(2)=0
DimmTextObjAsAcadMText
SetmTextObj=BlockObj.AddMText(iPt,rw,s)'"{\f"&xlRange.Font.Name&";"&s&"}")
mTextObj.LineSpacingFactor=0.75
mTextObj.Height=PToM(xlRange.Font.Size)
'�������ֵĶ��뷽ʽ
DimtPtAsVariant
IfxlRange.VerticalAlignment=xlTopAnd(xlRange.HorizontalAlignment=xlLeftOrxlRange.HorizontalAlignment=xlGeneral)Then
mTextObj.AttachmentPoint=acAttachmentPointTopLeft
tPt=iPt
ElseIfxlRange.VerticalAlignment=xlTopAndxlRange.HorizontalAlignment=xlCenterThen
mTextObj.AttachmentPoint=acAttachmentPointTopCenter
tPt=ThisDrawing.Utility.PolarPoint(iPt,0,rw/2)
ElseIfxlRange.VerticalAlignment=xlTopAndxlRange.HorizontalAlignment=xlRightThen
mTextObj.AttachmentPoint=acAttachmentPointTopRight
tPt=ThisDrawing.Utility.PolarPoint(iPt,0,rw)
ElseIfxlRange.VerticalAlignment=xlCenterAnd(xlRange.HorizontalAlignment=xlLeft_
OrxlRange.HorizontalAlignment=xlGeneral)Then
mTextObj.AttachmentPoint=acAttachmentPointMiddleLeft
tPt=ThisDrawing.Utility.PolarPoint(iPt,-1.5707963,rh/2)
ElseIfxlRange.VerticalAlignment=xlCenterAndxlRange.HorizontalAlignment=xlCenterThen
mTextObj.AttachmentPoint=acAttachmentPointMiddleCenter
tPt=ThisDrawing.Utility.PolarPoint(iPt,-1.5707963,rh/2)
tPt=ThisDrawing.Utility.PolarPoint(tPt,0,rw/2)
ElseIfxlRange.VerticalAlignment=xlCenterAndxlRange.HorizontalAlignment=xlRightThen
mTextObj.AttachmentPoint=acAttachmentPointMiddleRight
tPt=ThisDrawing.Utility.PolarPoint(iPt,-1.5707963,rh/2)
tPt=ThisDrawing.Utility.PolarPoint(tPt,0,rw/2)
ElseIfxlRange.VerticalAlignment=xlBottomAnd(xlRange.HorizontalAlignment=xlLeft_
OrxlRange.HorizontalAlignment=xlGeneral)Then
mTextObj.AttachmentPoint=acAttachmentPointBottomLeft
tPt=ThisDrawing.Utility.PolarPoint(iPt,-1.5707963,rh)
ElseIfxlRange.VerticalAlignment=xlBottomAndxlRange.HorizontalAlignment=xlCenterThen
mTextObj.AttachmentPoint=acAttachmentPointBottomCenter
tPt=ThisDrawing.Utility.PolarPoint(iPt,-1.5707963,rh)
tPt=ThisDrawing.Utility.PolarPoint(tPt,0,rw/2)
ElseIfxlRange.VerticalAlignment=xlBottomAndxlRange.HorizontalAlignment=xlRightThen
mTextObj.AttachmentPoint=acAttachmentPointBottomRight
tPt=ThisDrawing.Utility.PolarPoint(iPt,-1.5707963,rh)
tPt=ThisDrawing.Utility.PolarPoint(tPt,0,rw)
EndIf
mTextObj.InsertionPoint=tPt
SetmTextObj=Nothing
EndSub
'������ɺ���
'ע�����岻��ת���ijߴ���ƫ�����Լ��趨һ��ת������
FunctionPToM(ByValPointsAsDouble)AsDouble
PToM=Points*0.3527778
EndFunction
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- Excel 表格 CAD VBA