fires
路人甲
路人甲
  • 注册日期2005-01-14
  • 发帖数4
  • QQ
  • 铜币127枚
  • 威望0点
  • 贡献值0点
  • 银元0个
阅读:1497回复:1

[求助]MO网上发布问题 附源码

楼主#
更多 发布于:2006-04-27 21:05
<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>
喜欢0 评分0
太子☆哥
路人甲
路人甲
  • 注册日期2006-11-09
  • 发帖数9
  • QQ
  • 铜币131枚
  • 威望0点
  • 贡献值0点
  • 银元0个
1楼#
发布于:2006-11-20 22:53
兄弟~你是用VB做的???VB做的好象根本不能实现发布哦??VB.NET
举报 回复(0) 喜欢(0)     评分
游客

返回顶部