AutoCAD文字处理VB编程.docx
- 文档编号:23274095
- 上传时间:2023-05-15
- 格式:DOCX
- 页数:26
- 大小:41.68KB
AutoCAD文字处理VB编程.docx
《AutoCAD文字处理VB编程.docx》由会员分享,可在线阅读,更多相关《AutoCAD文字处理VB编程.docx(26页珍藏版)》请在冰豆网上搜索。
AutoCAD文字处理VB编程
OptionExplicit
DimoExcelAsObject
PrivateDeclareFunctionlstrlenLib"kernel32"Alias"lstrlenA"(ByVallpStringAsString)AsLong
DimoBookAsObject
DimoSheetAsObject
DimoAutoCADAsObject
DimoModelSpaceAsObject
DimoSelSetAsObject
DimoMTextAsObject
DimoTextAsObject
DimoTextStylesAsObject
'ÒÔÏ¿ÉÁгö¼¸ºõËùÓкº×Ö
'ForI=19968To40869
'Cells(I-19967,1)=ChrW(I)
'Next
PrivateFunctionBeingChinese(ByValCharacterAsString)AsBoolean'ºº×Ö
BeingChinese=False
DimIAsInteger
ForI=1ToLen(Character)
IfAsc(Mid(Character,I,1))<0Then
BeingChinese=True
ExitFor
EndIf
NextI
EndFunction
PrivateFunctionBeingDoubleByte(ByValCharacterAsString)AsBoolean'Ë«×Ö½Ú
Iflstrlen(Character)-Len(Character)>0Then
BeingDoubleByte=True
Else
BeingDoubleByte=False
EndIf
EndFunction
PrivateFunctionFullNameOfFile(ByValPathOfFileAsString,ByValNameOfFileAsString)AsString
FullNameOfFile=IIf(Right(PathOfFile,1)="\",PathOfFile&NameOfFile,PathOfFile&"\"&NameOfFile)
EndFunction
PrivateSubBindAutoCAD()
IfNotoAutoCADIsNothingThenExitSub
OnErrorResumeNext
SetoAutoCAD=GetObject(,"Autocad.Application")
IfErr.Number<>0Then'ûÓдò¿ª
Err.Clear
SetoAutoCAD=CreateObject("Autocad.application")
IfErr.Number<>0Then
Err.Clear
ExitSub
EndIf
oAutoCAD.Visible=True
EndIf
'²»ÂÛSingleDocumentModeµÄÖµ(Âß¼Öµ)£¬Ö±½Ó´ò¿ªÄ£°å
IfoAutoCAD.documents.Count=0ThenoAutoCAD.documents.AddFullNameOfFile(App.Path,"wcad.dwt")
IfErr.Number<>0ThenErr.Clear
OnErrorGoTo0
EndSub
PrivateSubBindExcel()
IfNotoExcelIsNothingThenExitSub
OnErrorResumeNext
SetoExcel=GetObject(,"Excel.Application")
IfErr.Number<>0Then'ûÓдò¿ª
Err.Clear
SetoExcel=CreateObject("Excel.application")
IfErr.Number<>0Then
Err.Clear
ExitSub
EndIf
oExcel.Visible=True
EndIf
OnErrorGoTo0
EndSub
PrivateSubUnBindExcel()
OnErrorResumeNext
SetoExcel=Nothing
SetoBook=Nothing
SetoSheet=Nothing
OnErrorGoTo0
EndSub
PrivateSubUnBindAutoCAD()
OnErrorResumeNext
SetoAutoCAD=Nothing
SetoModelSpace=Nothing
SetoSelSet=Nothing
SetoMText=Nothing
SetoText=Nothing
SetoTextStyles=Nothing
OnErrorGoTo0
EndSub
PrivateSubGetAllText()
OnErrorGoToERR_GETALLTEXT
BindAutoCAD
BindExcel
'Changethemousepointertoanhourglass.
Screen.MousePointer=11
DimI,J,IRowAsInteger
DimDuplicateAsBoolean
IfNotoAutoCADIsNothingOrNotoExcelIsNothingThen
SetoModelSpace=oAutoCAD.ActiveDocument.ModelSpace
SetoBook=oExcel.Workbooks.Add
IfErr.Number<>0Then
Err.Clear
ExitSub
EndIf
IfoBookIsNothingThenExitSub
SetoSheet=oBook.Sheets
(1)'µÚ1Ò³Ö½
IfoSheetIsNothingThenExitSub
IRow=0
ForI=0TooModelSpace.Count-1
WithoModelSpace.Item(I)
DoEvents
If.EntityName="AcDbMText"Or.EntityName="AcDbText"Then
lblTip=.textString
IfBeingChinese(.textString)Then'Óкº×Ö
Duplicate=False
ForJ=1ToIRow
If.textString=oSheet.Cells(J,1)Then
Duplicate=True
ExitFor
EndIf
NextJ
IfNotDuplicateThen'±ÜÃâÖظ´
IRow=IRow+1
oSheet.Cells(IRow,1)=.textString'\PÊÇÐмäÓ²»Ø³µ
EndIf
EndIf
EndIf
EndWith
NextI
EndIf
OnErrorGoTo0
'Resetthemousepointer.
Screen.MousePointer=0
lblTip="¹²µ¼³ö"+Str(IRow)+"´¦ÎÄ×Ö¡£"
UnBindExcel
UnBindAutoCAD
ExitSub
ERR_GETALLTEXT:
'Resetthemousepointer.
Screen.MousePointer=0
UnBindExcel
UnBindAutoCAD
lblTip=Err.Number&"Error:
"&Err.Description
EndSub
PrivateSubGetPartText()
OnErrorGoToERR_GETPARTTEXT
BindAutoCAD
BindExcel
'Changethemousepointertoanhourglass.
Screen.MousePointer=11
DimI,J,IRowAsInteger
DimDuplicateAsBoolean
DimSelPartAsString
IfNotoAutoCADIsNothingOrNotoExcelIsNothingThen
Randomize
SelPart="S"&CStr(Int(10000*Rnd)+1)
SetoSelSet=oAutoCAD.ActiveDocument.SelectionSets.Add(SelPart)
AppActivateoAutoCAD.Caption
oSelSet.SelectOnScreen
SetoBook=oExcel.Workbooks.Add
IfErr.Number<>0Then
Err.Clear
ExitSub
EndIf
IfoBookIsNothingThenExitSub
SetoSheet=oBook.Sheets
(1)'µÚ1Ò³Ö½
IfoSheetIsNothingThenExitSub
IRow=0
ForI=0TooSelSet.Count-1
WithoSelSet.Item(I)
DoEvents
If.EntityName="AcDbMText"Or.EntityName="AcDbText"Then
lblTip=.textString
IfBeingChinese(.textString)Then'Óкº×Ö
Duplicate=False
ForJ=1ToIRow
If.textString=oSheet.Cells(J,1)Then
Duplicate=True
ExitFor
EndIf
NextJ
IfNotDuplicateThen'±ÜÃâÖظ´
IRow=IRow+1
oSheet.Cells(IRow,1)=.textString'\PÊÇÐмäÓ²»Ø³µ
EndIf
EndIf
EndIf
EndWith
NextI
AppActivateoExcel.Caption
EndIf
OnErrorGoTo0
'Resetthemousepointer.
Screen.MousePointer=0
lblTip="¹²µ¼³ö"+Str(IRow)+"´¦ÎÄ×Ö¡£"
UnBindExcel
UnBindAutoCAD
ExitSub
ERR_GETPARTTEXT:
'Resetthemousepointer.
Screen.MousePointer=0
UnBindExcel
UnBindAutoCAD
lblTip=Err.Number&"Error:
"&Err.Description
EndSub
PrivateSubPutAllText()
OnErrorGoToERR_PUTALLTEXT
BindAutoCAD
BindExcel
'Changethemousepointertoanhourglass.
Screen.MousePointer=11
DimI,J,IRowAsInteger
IfNotoAutoCADIsNothingOrNotoExcelIsNothingThen
SetoModelSpace=oAutoCAD.ActiveDocument.ModelSpace
IfNotLCase(Right(Trim(txtBook),4))=".xls"ThentxtBook=txtBook&".xls"
SetoBook=oExcel.Workbooks.Open(FullNameOfFile(App.Path,txtBook),,False)
DimExistSheetAsBoolean
ExistSheet=False
ForI=1TooBook.Sheets.Count
IfTrim(LCase(oBook.Sheets(I).Name))=Trim(LCase(txtSheet))Then
SetoSheet=oBook.Sheets(I)'µÚijҳֽ
ExistSheet=I
EndIf
NextI
IfNotExistSheetThenGoToERR_PUTALLTEXT
IRow=0
ForI=0TooModelSpace.Count-1
WithoModelSpace.Item(I)
DoEvents
If.EntityName="AcDbMText"Or.EntityName="AcDbText"Then
lblTip=.textString
ForJ=CInt(txtFromRow)ToCInt(txtToRow)
If.textString=oSheet.Cells(J,txtFromCol)AndNotTrim(oSheet.Cells(J,txtFromCol))=""Then
IRow=IRow+1
.textString=oSheet.Cells(J,txtToCol)
EndIf
NextJ
EndIf
EndWith
NextI
EndIf
OnErrorGoTo0
'Resetthemousepointer.
Screen.MousePointer=0
lblTip="¹²Ìæ»»"+Str(IRow)+"´¦ÎÄ×Ö¡£"
UnBindExcel
UnBindAutoCAD
ExitSub
ERR_PUTALLTEXT:
'Resetthemousepointer.
Screen.MousePointer=0
UnBindExcel
UnBindAutoCAD
lblTip=Err.Number&"Error:
"&Err.Description
EndSub
PrivateSubPutPartText()
OnErrorGoToERR_PUTPARTTEXT
BindAutoCAD
BindExcel
'Changethemousepointertoanhourglass.
Screen.MousePointer=11
DimI,J,IRowAsInteger
DimSelPartAsString
IfNotoAutoCADIsNothingOrNotoExcelIsNothingThen
Randomize
SelPart="S"&CStr(Int(10000*Rnd)+1)
SetoSelSet=oAutoCAD.ActiveDocument.SelectionSets.Add(SelPart)
AppActivateoAutoCAD.Caption
oSelSet.SelectOnScreen
IfNotLCase(Right(Trim(txtBook),4))=".xls"ThentxtBook=txtBook&".xls"
SetoBook=oExcel.Workbooks.Open(FullNameOfFile(App.Path,txtBook),,False)
DimExistSheetAsBoolean
ExistSheet=False
ForI=1TooBook.Sheets.Count
IfTrim(LCase(oBook.Sheets(I).Name))=Trim(LCase(txtSheet))Then
SetoSheet=oBook.Sheets(I)'µÚijҳֽ
ExistSheet=I
EndIf
NextI
IfNotExistSheetThenGoToERR_PUTPARTTEXT
IRow=0
ForI=0TooSelSet.Count-1
WithoSelSet.Item(I)
DoEvents
If.EntityName="AcDbMText"Or.EntityName="AcDbText"Then
lblTip=.textString
ForJ=CInt(txtFromRow)ToCInt(txtToRow)
If.textString=oSheet.Cells(J,txtFromCol)AndNotTrim(oSheet.Cells(J,txtFromCol))=""Then
IRow=IRow+1
.textString=oSheet.Cells(J,txtToCol)
EndIf
NextJ
EndIf
EndWith
NextI
EndIf
OnErrorGoTo0
'Resetthemousepointer.
Screen.MousePointer=0
lblTip="¹²Ìæ»»"+Str(IRow)+"´¦ÎÄ×Ö¡£"
UnBindExcel
UnBindAutoCAD
ExitSub
ERR_PUTPARTTEXT:
'Resetthemousepointer.
Screen.MousePointer=0
UnBindExcel
UnBindAutoCAD
lblTip=Err.Number&"Error:
"&Err.Description
EndSub
PrivateSubTranAllText()
OnErrorGoToERR_TRANALLTEXT
BindAutoCAD
'Changethemousepointertoanhourglass.
Screen.MousePointer=11
DimI,ICountAsInteger
Diminspoi(0To2)AsDouble
DimpntAsVariant
ICount=0
IfNotoAutoCADIsNothingThen
SetoModelSpace=oAutoCAD.ActiveDocument.ModelSpace
IfErr.Number<>0Then
Err.Clear
ExitSub
EndIf
ForI=oModelSpace.Count-1To0Step-1
shpPro.Width=(1-I/oModelSpace.Count)*picBack.Width
WithoModelSpace.Item(I)
DoEvents
If.EntityName="AcDbMText"Then
.textString=TrimMText(.textString)
.StyleName="Standard"
ICount=ICount+1
lblTip.Caption="ÐÞ¸Ä×Ö·û¸öÊý£º"&CStr(ICount)
EndIf
If.EntityName="AcDbText"Then
pnt=.insertionPoint
inspoi(0)=pnt(0)
inspoi
(1)=pnt
(1)+.Height
inspoi
(2)=pnt
(2)
SetoMText=oModelSpace.AddMtext(inspoi,.Height*256,TrimMText(.textString))
oMText.Height=.Height
oMText.StyleName="Standard"
.Delete
ICount=ICount+1
lblTip.Caption="ÐÞ¸Ä×Ö·û¸öÊý£º"&CStr(ICount)
EndIf
EndWith
NextI
shpPro.Width=picBack.Width
EndIf
SetoTextStyles=oAutoCAD.ActiveDocument.TextStyles("standard")
oTextStyles.fontfile="times.ttf"'TimesNewRoman
OnErrorGoTo0
'Resetthemousepointer.
Screen.MousePointer=0
UnBindAutoCAD
ExitSub
ERR_TRANALLTEXT:
'Resetthemousepointer.
Screen.MousePointer=0
UnBindAutoCAD
lblTip=Err.Number&"Error:
"&Err.Description
EndSub
PrivateSubTranPartText()
OnErrorGoToER
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- AutoCAD 文字处理 VB 编程