|
阅读：3589回复：17
[分享]DBA的VB+AO的开发总结zz
<P>看到这个写得不错，所以转过来大家看看，大家可以讨论下，也可以解决大家在开发中的一些难题。</P>
<P>项目结构是DB管理工具把文本倒入Oracle数据库，然后上层开发读库显示。用户操作过程中选择产生的中间结果也都要求DB提供临时表，显示的部分Join该临时表用于显示，临时表的删除是夜间批处理。 </P> <br> <P>VB+AO的开发是现学现用，希望能让将来的同志节约点时间。</P> <P><B>创建到Oracle的连接</B> <P><BR>"******************************************************************<BR>"Function: SDEConnect will create the connection to SDE Database<BR>"Input : Server , Instance, User, Password<BR>"Output : IFeatureWorkspace struction<BR>"******************************************************************<BR>Public Function SDEConnect(ByVal server As String, _<BR> ByVal instance As String, _<BR> ByVal user As String, _<BR> ByVal password As String) As IFeatureWorkspace<BR> <BR>On Error GoTo Error_h<BR> "Create ArcSDE Connection<BR> Dim pPropertyset As IPropertySet<BR> Set pPropertyset = New PropertySet<BR> <BR> "Set SDE DB Connect info here<BR> With pPropertyset<BR> .SetProperty "SERVER", server<BR> .SetProperty "INSTANCE", instance<BR> .SetProperty "USER", user<BR> .SetProperty "PASSWORD", password<BR> .SetProperty "VERSION", "SDE.DEFAULT"<BR> End With<BR> "Open WorkSpace<BR> Dim pWorkspaceFactory As IWorkspaceFactory<BR> Set pWorkspaceFactory = New SdeWorkspaceFactory<BR> Dim pFWS As IFeatureWorkspace<BR> Set pFWS = pWorkspaceFactory.Open(pPropertyset, 0)<BR> "CleanUp<BR> Set pPropertyset = Nothing<BR> Set pWorkspaceFactory = Nothing<BR> Set SDEConnect = pFWS<BR> Exit Function<BR>Error_h:<BR> Set pPropertyset = Nothing<BR> Set pWorkspaceFactory = Nothing<BR> MsgBox "SDEConnect()"<BR>End Function </P> |
|
|
|
1楼#
发布于：2005-07-08 15:20
<P>辛苦了</P><img src="images/post/smile/dvbbs/em05.gif" />
|
|
|
2楼#
发布于：2005-06-30 21:12
<P><img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /></P>
<P><img src="images/post/smile/dvbbs/em05.gif" /><img src="images/post/smile/dvbbs/em05.gif" /><img src="images/post/smile/dvbbs/em05.gif" /><img src="images/post/smile/dvbbs/em05.gif" /></P> |
|
|
3楼#
发布于：2005-06-29 14:53
<img src="images/post/smile/dvbbs/em06.gif" />
|
|
|
4楼#
发布于：2005-06-27 23:36
<img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em01.gif" />
|
|
|
5楼#
发布于：2005-06-15 13:23
<img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" />
|
|
|
6楼#
发布于：2005-06-14 15:29
<img src="images/post/smile/dvbbs/em01.gif" />
|
|
|
7楼#
发布于：2005-06-08 19:35
赶卸<img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em04.gif" /><img src="images/post/smile/dvbbs/em08.gif" /><img src="images/post/smile/dvbbs/em05.gif" />
|
|
|
|
8楼#
发布于：2005-06-01 17:50
工具条的功能是在一个Layer上面画方框，并保存方框到刚才创建的那个Polygon表里面，提供 ZoomIn/ZoomOut/FullExtent/DrawRectangle/SelectTool功能。<BR>该工具条在Dialog中与AO一起使用。<BR>画方框的功能是从例子RasterEditor中摘抄的
<br> <P>Option Explicit</P> <P>"Windows API functions to capture mouse and keyboard<BR>"input to a window when the mouse is outside the window<BR>Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long<BR>Private Declare Function GetCapture Lib "user32" () As Long<BR>Private Declare Function ReleaseCapture Lib "user32" () As Long</P> <P>Private m_pHook As New Hook<BR>Private WithEvents ActiveViewEvents As Map<BR>Private m_bInUse As Boolean<BR>Private m_pBitmap As IPictureDisp<BR>Private m_pEnvFeedback As INewEnvelopeFeedback</P> <P>Private Const VK_CONTROL = ;H11<BR>Private Const VK_SHIFT = ;H10<BR>Private Declare Function GetKeyState% Lib "user32" (ByVal nKey%)</P> <P>Implements ICommand<BR>Implements ITool</P> <P>" Constant used by the Error handler function - DO NOT REMOVE<BR>Const c_ModuleFileName = "clsDrawRectangle.cls"<BR>" Package Name<BR>Const MeName = "DrawRectagle Command"</P> <P>Private Sub Class_Initialize()<BR>On Error GoTo Error_h<BR> Set m_pBitmap = LoadResPicture("DrawRectangle", vbResBitmap)<BR> Exit Sub<BR>Error_h:<BR> HandleError True, "Class_Initialize " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1<BR>End Sub</P> <P>Private Sub Class_Terminate()<BR>On Error GoTo Error_h<BR> Set m_pHook = Nothing<BR> Exit Sub<BR>Error_h:<BR> HandleError True, "Class_Terminate " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1<BR>End Sub</P> <P>Private Property Get ICommand_Enabled() As Boolean<BR> ICommand_Enabled = True<BR>End Property</P> <P>Private Property Get ICommand_Checked() As Boolean<BR> ICommand_Checked = False<BR>End Property<BR><BR>Private Property Get ICommand_Name() As String<BR> ICommand_Name = "Draw Rectangle"<BR>End Property</P> <P>Private Property Get ICommand_Caption() As String<BR> ICommand_Caption = "Draw Rectangle"<BR>End Property</P> <P>Private Property Get ICommand_Tooltip() As String<BR> ICommand_Tooltip = "Draw Rectangle"<BR>End Property<BR><BR>Private Property Get ICommand_Message() As String<BR> ICommand_Message = "Draw Rectangle"<BR>End Property</P> <P>Private Property Get ICommand_HelpFile() As String</P> <P>End Property<BR><BR>Private Property Get ICommand_HelpContextID() As Long</P> <P>End Property<BR><BR>Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE<BR>On Error GoTo Error_h<BR> ICommand_Bitmap = m_pBitmap<BR> Exit Property<BR>Error_h:<BR> HandleError True, "ICommand_Bitmap " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1<BR>End Property</P> <P>Private Property Get ICommand_Category() As String<BR>On Error GoTo Error_h<BR> ICommand_Category = "Rectangle Tools"<BR> Exit Property<BR>Error_h:<BR> HandleError True, "ICommand_Category " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1<BR>End Property</P> <P>Private Sub ICommand_OnCreate(ByVal Hook As Object)<BR>On Error GoTo Error_h<BR> m_pHook.Hook = Hook<BR> Exit Sub<BR>Error_h:<BR> HandleError True, "ICommand_OnCreate " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1<BR>End Sub</P> <P>Private Sub ICommand_OnClick()</P> <P>End Sub</P> <P>Private Property Get ITool_Cursor() As esriCore.OLE_HANDLE<BR>On Error GoTo Error_h<BR> ITool_Cursor = LoadResPicture("Digitize", vbResCursor)<BR> Exit Property<BR>Error_h:<BR> HandleError True, "ITool_Cursor " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1<BR>End Property</P> <P>Private Function ITool_Deactivate() As Boolean</P> <P>End Function</P> <P>Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean</P> <P>End Function</P> <P>Private Sub ITool_OnDblClick()</P> <P>End Sub</P> <P>Private Sub ITool_OnKeyDown(ByVal keyCode As Long, ByVal Shift As Long)<BR> " Delete Rectangle when Delete Key pressed<BR> If keyCode = vbKeyDelete Then<BR> Dim pGC As IGraphicsContainer<BR> Set pGC = m_pHook.FocusMap<BR> pGC.DeleteAllElements<BR> <BR> Dim pActiveView As esriCore.IActiveView<BR> Set pActiveView = GetMap(m_pHook)<BR> pActiveView.Refresh<BR> End If<BR>End Sub</P> <P>Private Sub ITool_OnKeyUp(ByVal keyCode As Long, ByVal Shift As Long)<BR> Exit Sub<BR>End Sub</P> <P>Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)<BR>On Error GoTo Error_h<BR> " Get ActiveView<BR> Dim pActiveView As esriCore.IActiveView<BR> Set pActiveView = GetMap(m_pHook)<BR> " Clear the old one<BR> Dim pGC As IGraphicsContainer<BR> Set pGC = m_pHook.FocusMap<BR> pGC.DeleteAllElements<BR> " Create FeedBack Rectangle<BR> Set m_pEnvFeedback = New NewEnvelopeFeedback<BR> Set m_pEnvFeedback.Display = pActiveView.ScreenDisplay<BR> m_pEnvFeedback.Start pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)<BR> m_bInUse = True<BR> Exit Sub<BR>Error_h:<BR> HandleError True, "ITool_OnMouseDown " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1<BR>End Sub</P> <P>Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)<BR>On Error GoTo Error_h<BR> Dim pActiveView As esriCore.IActiveView<BR> Set pActiveView = GetMap(m_pHook)<BR> <BR> If (m_bInUse And Not m_pEnvFeedback Is Nothing) Then<BR> m_pEnvFeedback.MoveTo pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)<BR> End If<BR> Exit Sub<BR>Error_h:<BR> HandleError True, "ITool_OnMouseMove " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1<BR>End Sub</P> <P>Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)<BR>On Error GoTo Error_h<BR> If (Not m_bInUse) Then Exit Sub<BR> <BR> Dim pGeom As IGeometry<BR> Dim pAv As IActiveView<BR> Dim pElement As IElement<BR> Dim pGC As IGraphicsContainer<BR> Dim pGCSelect As IGraphicsContainerSelect<BR> <BR> Set pAv = m_pHook.FocusMap<BR> Set pGeom = m_pEnvFeedback.Stop<BR> <BR> Dim pActiveView As esriCore.IActiveView<BR> Set pActiveView = GetMap(m_pHook)<BR> <BR> If (pGeom.IsEmpty) Then<BR> Set pGeom = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)<BR> Exit Sub<BR> End If<BR> <BR> Set pElement = CreateSelectionBox(pGeom)<BR> Set pGC = pAv<BR> pGC.AddElement pElement, 0<BR> <BR> Set pGCSelect = pGC<BR> pGCSelect.UnselectAllElements<BR> pGCSelect.SelectElement pElement<BR> pAv.Refresh<BR> <BR> Set m_pEnvFeedback = Nothing<BR> m_bInUse = False<BR> Exit Sub<BR>Error_h:<BR> HandleError True, "ITool_OnMouseUp " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1<BR>End Sub</P> <P>Private Sub ITool_Refresh(ByVal hDC As esriCore.OLE_HANDLE)</P> <P>End Sub</P> <P>Public Function CreateSelectionBox(pGeom As IGeometry) As IElement<BR>On Error GoTo Error_h<BR> Dim pElement As IElement<BR> Set pElement = New RectangleElement<BR> " Set Symbology<BR> Dim pSymbol As ISimpleFillSymbol<BR> Set pSymbol = New SimpleFillSymbol<BR> <BR> Dim pLineSymbol As ISimpleLineSymbol<BR> Set pLineSymbol = New SimpleLineSymbol<BR> " Set Line Color and Width , Can be changed as need<BR> Dim pLineColor As IColor<BR> Set pLineColor = New RgbColor<BR> pLineColor.RGB = RGB(255, 255, 255)<BR> pLineColor.Transparency = 255<BR> <BR> pLineSymbol.Color = pLineColor<BR> pLineSymbol.Width = 2<BR> pLineSymbol.Style = esriSLSSolid<BR> <BR> pSymbol.Outline = pLineSymbol<BR> pSymbol.Style = esriSFSNull<BR> " Create Box enclosed the rectangle you draw<BR> Dim pFillShapeElement As IFillShapeElement<BR> Set pFillShapeElement = pElement<BR> pFillShapeElement.Symbol = pSymbol<BR> pElement.Geometry = pGeom<BR> Set CreateSelectionBox = pElement<BR> Exit Function<BR>Error_h:<BR> HandleError True, "CreateSelectionBox " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1<BR>End Function</P> |
|
|
|
9楼#
发布于：2005-06-01 17:50
就是纯粹的数据表文件<BR>Private Function CopyTable(pSrcWorkSpace As IFeatureWorkspace, _<BR> pDstWorkSpace As IFeatureWorkspace, _<BR> strTableName As String) As Boolean<BR>On Error GoTo Error_h<BR> " Open Source Table<BR> Dim pDBFTable As ITable<BR> Set pDBFTable = pSrcWorkSpace.OpenTable(strTableName)<BR> <BR> Dim pDBFFields As IFields<BR> Set pDBFFields = pDBFTable.Fields<BR> " Open Destination Table<BR> Dim pSDETable As ITable<BR> If SDEFeatureExist(strTableName, pDstWorkSpace) Then<BR> Set pSDETable = pDstWorkSpace.OpenTable(strTableName)<BR> Else<BR> " If doesn"t exist , Create a New One<BR> Set pSDETable = pDstWorkSpace.CreateTable(strTableName, pDBFFields, Nothing, Nothing, "")<BR> End If<BR> " Select All rows from Source<BR> Dim pDBFCursor As ICursor<BR> Set pDBFCursor = pDBFTable.Search(Nothing, True)<BR> <BR> Dim pDBFRow As IRow<BR> Set pDBFRow = pDBFCursor.NextRow<BR> " Prepare Insert Cursor for Destination Table<BR> Dim pSDERow As IRow<BR> Dim pSDECursor As ICursor<BR> Set pSDECursor = pSDETable.Insert(False)<BR> " Copy Rows<BR> Dim i As Long<BR> Do Until pDBFRow Is Nothing<BR> Set pSDERow = pSDETable.CreateRow<BR> For i = 0 To pDBFFields.FieldCount - 1<BR> If Not pDBFFields.Field(i).Type = esriFieldTypeOID Then _<BR> pSDERow.value(i) = pDBFRow.value(i)<BR> Next i<BR> pSDECursor.InsertRow pSDERow<BR> Set pDBFRow = pDBFCursor.NextRow<BR> Loop<BR> CopyTable = True<BR> Exit Function<BR>Error_h:<BR> MsgLogOut Me.Name, "CopyTable", False, strTableName<BR>End Function<BR>
|
|
|
上一页
下一页