阅读:1497回复:1
[求助]MO网上发布问题 附源码
<P><FONT color=#ee113d>我想在frmWeb中调用Form1中的gisWeb函数实现本程序的网上发布,但是当点击frmWeb中的Command1执行程序时总是出现“438对象不支持该属性或方法”的错误,代码在上面,请高手指教</FONT></P>
<P><IMG src="http://bbs.gissky.net/images/upfile/2006-4/2006427205846.bmp" border=0></P> <P><FONT color=#ee113d></FONT> </P> <P>'------------------------------------------------------------<BR>'Form1<BR>'------------------------------------------------------------</P> <P>Dim r As MapObjects2.Rectangle<BR>Dim g_feedback As DragFeedback</P> <P>Private Sub Form_Load()<BR> DrawLayer '加载美国地图;<BR> <BR>End Sub</P> <P>Private Sub Map1_AfterLayerDraw(ByVal index As Integer, ByVal canceled As Boolean, </P> <P>ByVal hdc As stdole.OLE_HANDLE)<BR> If index = 0 Then<BR> Map2.TrackingLayer.Refresh True<BR> End If<BR>End Sub</P> <P>Private Sub Map1_BeforeLayerDraw(ByVal index As Integer, ByVal hdc As </P> <P>stdole.OLE_HANDLE)<BR> Dim layer As MapObjects2.MapLayer<BR> Set layer = Map1.Layers(index)<BR> If index = 1 Then 'counties<BR> If Map1.Extent.Width > (Map1.FullExtent.Width / 4) Then<BR> 'Label1.Caption = "没有放大4倍以上,不显示县地图。"<BR> layer.Visible = False<BR> Else<BR> 'Label1.Caption = "已经放大4倍以上,显示县地图!"<BR> layer.Visible = True<BR> End If<BR> End If<BR>End Sub</P> <P>Private Sub Map1_DblClick()<BR> Dim r As MapObjects2.Rectangle<BR> Set r = Map1.Extent<BR> r.ScaleRectangle 2<BR> Map1.Extent = r</P> <P>End Sub</P> <P>Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As </P> <P>Single)<BR> If Toolbar1.Buttons(1).Value = 1 Then<BR> Set Map1.Extent = Map1.TrackRectangle<BR> ElseIf Toolbar1.Buttons(3).Value = 1 Then<BR> Map1.Pan<BR> ElseIf Toolbar1.Buttons(2).Value = 1 Then<BR> Set r = Map1.Extent<BR> r.ScaleRectangle 1.5<BR> Map1.Extent = r<BR> End If<BR>End Sub</P> <P>Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)<BR> Dim sym As New Symbol<BR> sym.OutlineColor = moRed<BR> sym.Size = 2<BR> sym.Style = moTransparentFill<BR> Map2.DrawShape Map1.Extent, sym<BR>End Sub</P> <P>'实现用Map2改变Map1的功能;<BR>Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As </P> <P>Single)<BR> Dim curRectangle As MapObjects2.Rectangle<BR> Dim pt As New MapObjects2.Point<BR> '画方框改变Map1窗口<BR> Set curRectangle = Map2.TrackRectangle<BR> Set Map1.Extent = curRectangle<BR> '点击改变Map1位置<BR> Set pt = Map2.ToMapPoint(x, y)<BR> Map1.CenterAt pt.x, pt.y<BR> <BR> '将点击转换为Map2上的点对象;<BR> Dim p As Point<BR> Set p = Map2.ToMapPoint(x, y)<BR> <BR> '如果点击发生在方框内,开始拖动;<BR> If Map1.Extent.IsPointIn(p) Then<BR> Set g_feedback = New DragFeedback<BR> g_feedback.DragStart Map1.Extent, Map2, x, y<BR> End If<BR>End Sub</P> <P>'开始拖动方框<BR>Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As </P> <P>Single)<BR> If Not g_feedback Is Nothing Then<BR> g_feedback.DragMove x, y<BR> End If<BR>End Sub</P> <P>'拖动完成,并在Map1中显示新位置;<BR>Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, x As Single, y As </P> <P>Single)<BR> If Not g_feedback Is Nothing Then<BR> Map1.Extent = g_feedback.DragFinish(x, y)<BR> Set g_feedback = Nothing<BR> End If<BR>End Sub<BR>Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)<BR> If Toolbar1.Buttons(1).Value = 1 Then<BR> Map1.MousePointer = moZoomIn<BR> ElseIf Toolbar1.Buttons(3).Value = 1 Then<BR> Map1.MousePointer = moPan<BR> ElseIf Toolbar1.Buttons(2).Value = 1 Then<BR> Map1.MousePointer = moZoomOut<BR> ElseIf Toolbar1.Buttons(4).Value = 1 Then<BR> Set Map1.Extent = Map1.FullExtent<BR> Map1.MousePointer = moDefault<BR> ElseIf Toolbar1.Buttons(5).Value = 1 Then<BR> frmWeb.Show vbModal<BR> frmWeb.ZOrder 0<BR> Toolbar1.Buttons(5).Value = 0<BR> Map1.MousePointer = moDefault</P> <P> End If<BR>End Sub<BR>Sub DrawLayer()<BR> Dim dc As New DataConnection<BR> Dim layer As MapLayer<BR> dc.Database = App.Path + "\..\" + "USA"<BR> If Not dc.Connect Then<BR> MsgBox "在指定的文件夹下没找到图层数据文件!"<BR> End<BR> End If<BR> <BR> Set layer = New MapLayer<BR> Set layer.GeoDataset = dc.FindGeoDataset("Counties")<BR> layer.Symbol.Color = moYellow<BR> layer.Symbol.SymbolType = moFillSymbol<BR> layer.Symbol.Size = 1<BR> layer.Symbol.Style = 7<BR> layer.Symbol.OutlineColor = moGreen<BR> Map1.Layers.Add layer<BR> <BR> Set layer = New MapLayer<BR> Set layer.GeoDataset = dc.FindGeoDataset("STATES")<BR> layer.Symbol.Color = moPaleYellow<BR> layer.Symbol.SymbolType = moFillSymbol<BR> layer.Symbol.Style = 1<BR> layer.Symbol.Size = 2<BR> layer.Symbol.OutlineColor = moBrown<BR> '标注<BR> Set layer.Renderer = New LabelRenderer<BR> layer.Renderer.Field = "STATE_NAME" '指定要显示的字段<BR> layer.Renderer.Symbol(0).Color = moBlack<BR> layer.Renderer.Symbol(0).Height = 0.5<BR> layer.Renderer.AllowDuplicates = True<BR> Map1.Layers.Add layer<BR> <BR> Set layer = New MapLayer<BR> Set layer.GeoDataset = dc.FindGeoDataset("STATES")<BR> layer.Symbol.Color = moPaleYellow<BR> Map2.Layers.Add layer<BR> Map2.Refresh<BR> <BR>End Sub</P> <P>Public Sub gisWeb(GisTitle As String, GisFileName As String, GisAddr As String)<BR> Dim Strn As Integer<BR> Dim Di As Integer<BR> <BR> Di = 1<BR> Strn = Len(GisTitle)<BR> On Error GoTo objError<BR> <BR> Clipboard.Clear<BR> Map1.CopyMap 1<BR> <BR> Const CLASSOBJECT = "Word.Application"<BR> Set objword = CreateObject(CLASSOBJECT)<BR> objword.Visible = True '显示Word程序<BR> objword.Document.Add '增加一个Word文档,Application.Documents嵌套类<BR> <BR> <BR> With objword<BR> .selection.TypeText Text:=GisTitle<BR> .selection.MoveLeft Unit:=wdCharacter, Count:=Strn, Exrend:=wdExtend<BR> If Di = 1 Then<BR> .selection.Font.Size = 26<BR> ElseIf Di = 0 Then<BR> .selection.Font.Size = 32<BR> End If<BR> .selection.Font.Bold = wdToggle<BR> .selection.ParagraphFormat.Alignment = wbAlignPharagraphCenter<BR> .selection.MoveRight Unit:=wdCharacter, Count:=1<BR> <BR> <BR> .selection.TypeParagraph<BR> .selection.Paste<BR> .selection.MoveLeft Unit:=wdCharacter, Count:=2<BR> .selection.MoveDown Unit:=wdLine, Count:=1<BR> .selection.InlineShapes(1).Borders(wdBorderLeft).LineStyle = wdLineStyleDouble<BR> .selection.InlineShapes(1).Borders(wdBorderLeft).LineWidth = wdLineWidth050pt<BR> .selection.InlineShapes(1).Borders(wdBorderLeft).Color = wdColorAutomatic<BR> <BR> .selection.InlineShapes(1).Borders(wdBorderRight).LineStyle = wdLineStyleDouble<BR> .selection.InlineShapes(1).Borders(wdBorderRight).LineWidth = wdLineWidth050pt<BR> .selection.InlineShapes(1).Borders(wdBorderRight).Color = wdColorAutomatic<BR> <BR> .selection.InlineShapes(1).Borders(wdBorderTop).LineStyle = wdLineStyleDouble<BR> .selection.InlineShapes(1).Borders(wdBorderTop).LineWidth = wdLineWidth050pt<BR> .selection.InlineShapes(1).Borders(wdBorderTop).Color = wdColorAutomatic<BR> <BR> .selection.InlineShapes(1).Borders(wdBorderBottom).LineStyle = </P> <P>wdLineStyleDouble<BR> .selection.InlineShapes(1).Borders(wdBorderBottom).LineWidth = wdLineWidth050pt<BR> .selection.InlineShapes(1).Borders(wdBorderBottom).Color = wdColorAutomatic<BR> <BR> .selection.InlineShapes(1).Borders.Shadow = False<BR> <BR> .Options.DefaultBorderLineStyle = wdLineStyleDouble<BR> .Options.DefaultBorderLineWidth = wdLineWidth050pt<BR> .Options.DefaultBorderColor = wdColorAutomatic</P> <P> .ChangeFileOpenDirectory GisAddr<BR> .ActiveDocument.SaveAs FileName:=GisFileName, FileFormat:=wdFormatHTML, _<BR> LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _<BR> :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _<BR> SaveNativePictureFormat:=False, SaveFormsData:=False, _<BR> SaveAsAOCELetter:=False</P> <P> .ActiveWindow.View.Type = wdWebView<BR> .Application.Quit 0<BR> End With<BR> Set objword = Nothing<BR> Exit Sub<BR> <BR>objError:<BR> If Err <> 429 Then<BR> MsgBox Str$(Err) ; ":" ; Error$, vbCritical, "错误"<BR> Set objword = Nothing<BR> Exit Sub<BR> Else<BR> Resume Next<BR> End If<BR> </P> <P>End Sub</P> <P>'---------------------------------------------------------------------------------<BR>'femWeb<BR>'---------------------------------------------------------------------------------</P> <P>Option Explicit</P> <P>Private Sub Command1_Click()<BR> Call Form1.gisWeb(Text1.Text, Text2.Text, Text3.Text)<BR> Unload Me<BR>End Sub</P> <P>Private Sub Form_Load()<BR> Text1.Text = "武汉公交管理系统"<BR> Text2.Text = "wuhangongjiao.htm"<BR> Text3.Text = "F:\Inetpub\wwwroot"<BR>End Sub</P> <P>'---------------------------------------------------------------------------------<BR></P> |
|
1楼#
发布于:2006-11-20 22:53
兄弟~你是用VB做的???VB做的好象根本不能实现发布哦??VB.NET
|
|