savemap.frm

MapInfo 行业应用源代码

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form SaveMap 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "保存图象"
   ClientHeight    =   3336
   ClientLeft      =   48
   ClientTop       =   336
   ClientWidth     =   6204
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   11.4
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "SaveMap.frx":0000
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3336
   ScaleWidth      =   6204
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.PictureBox Picture1 
      BackColor       =   &H80000001&
      Height          =   3132
      Left            =   120
      ScaleHeight     =   3084
      ScaleWidth      =   5964
      TabIndex        =   0
      Top             =   120
      Width           =   6012
      Begin VB.TextBox TextHeightT 
         Height          =   372
         Left            =   3600
         MaxLength       =   4
         TabIndex        =   15
         Text            =   "Text1"
         Top             =   1080
         Width           =   2292
      End
      Begin VB.TextBox TextWidthT 
         Height          =   372
         Left            =   1320
         MaxLength       =   4
         TabIndex        =   14
         Text            =   "Text1"
         Top             =   1080
         Width           =   2292
      End
      Begin VB.CommandButton CommandSaveFile 
         Caption         =   "..."
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.8
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   372
         Left            =   5280
         TabIndex        =   12
         Top             =   120
         Width           =   612
      End
      Begin VB.CommandButton SaveBMPCancel 
         Caption         =   "放弃"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   11.4
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   4680
         TabIndex        =   11
         Top             =   2280
         Width           =   1215
      End
      Begin VB.CommandButton SaveBMPOK 
         Caption         =   "确定"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   11.4
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   120
         TabIndex        =   10
         Top             =   2280
         Width           =   1215
      End
      Begin VB.OptionButton OptionType 
         Caption         =   "WMF"
         Height          =   375
         Index           =   3
         Left            =   5040
         TabIndex        =   9
         Top             =   1560
         Width           =   855
      End
      Begin VB.OptionButton OptionType 
         Caption         =   "TIF"
         Height          =   375
         Index           =   2
         Left            =   3840
         TabIndex        =   8
         Top             =   1560
         Width           =   855
      End
      Begin VB.OptionButton OptionType 
         Caption         =   "JPG"
         Height          =   375
         Index           =   1
         Left            =   2640
         TabIndex        =   7
         Top             =   1560
         Value           =   -1  'True
         Width           =   855
      End
      Begin VB.OptionButton OptionType 
         Caption         =   "BMP"
         Height          =   375
         Index           =   0
         Left            =   1440
         TabIndex        =   5
         Top             =   1560
         Width           =   855
      End
      Begin VB.ComboBox PaperNo 
         Height          =   324
         ItemData        =   "SaveMap.frx":0442
         Left            =   1320
         List            =   "SaveMap.frx":046D
         TabIndex        =   4
         Top             =   600
         Width           =   4572
      End
      Begin VB.TextBox FileNameBMP 
         Height          =   375
         Left            =   1320
         TabIndex        =   2
         Top             =   120
         Width           =   3855
      End
      Begin VB.Label LabelWidthHeight 
         Alignment       =   2  'Center
         Caption         =   "图纸宽、高"
         Height          =   372
         Left            =   120
         TabIndex        =   13
         Top             =   1080
         Width           =   1212
      End
      Begin VB.Label Label10 
         Alignment       =   2  'Center
         Caption         =   "图形格式"
         Height          =   372
         Index           =   1
         Left            =   120
         TabIndex        =   6
         Top             =   1560
         Width           =   1212
      End
      Begin VB.Label Label10 
         Alignment       =   2  'Center
         Caption         =   "选择图纸号"
         Height          =   375
         Index           =   0
         Left            =   120
         TabIndex        =   3
         Top             =   600
         Width           =   1215
      End
      Begin VB.Label Label2 
         Alignment       =   2  'Center
         BackColor       =   &H80000000&
         Caption         =   "文件名"
         Height          =   375
         Index           =   7
         Left            =   120
         TabIndex        =   1
         Top             =   120
         Width           =   1215
      End
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   0
      Top             =   0
      _ExtentX        =   677
      _ExtentY        =   677
      _Version        =   393216
   End
End
Attribute VB_Name = "SaveMap"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub CommandSaveFile_Click()
Dim I As Integer, TheOutPath As String, TheOutFile As String

On Error Resume Next
CommonDialog1.DialogTitle = "存放文件"
CommonDialog1.FileName = FileNameBMP.Text
CommonDialog1.Filter = "*.BMP|*.BMP|*.JPG|*.JPG|*.TIF|*.TIF|*.WMF|*.WMF"
''CommonDialog1.InitDir = TheInPath
CommonDialog1.FilterIndex = 0
CommonDialog1.ShowSave
If (Err = 0) Then '打开文件
    I = InStr(CommonDialog1.FileName, CommonDialog1.FileTitle)
    TheOutPath = Left(CommonDialog1.FileName, I - 1)
    TheOutFile = UCase(CommonDialog1.FileTitle)
    
    I = InStr(TheOutFile, ".")
    If (I > 0) Then
        TheOutFile = Left(TheOutFile, I)
    End If
    TheOutFile = TheOutFile + "BMP"

    FileNameBMP.Text = TheOutPath + TheOutFile
End If
End Sub

Private Sub Form_Load()
FileNameBMP.Text = TheOutFile
PaperNo.ListIndex = 3
bOKCancel = False
End Sub

Private Sub OptionType_Click(Index As Integer)
Dim StrIndex As String, I As Integer

If (Index = 1) Then
    StrIndex = "JPG"
ElseIf (Index = 2) Then
    StrIndex = "TIF"
ElseIf (Index = 3) Then
    StrIndex = "WMF"
Else
    StrIndex = "BMP"
End If
TheOutFile = FileNameBMP.Text
I = InStr(TheOutFile, ".")
If (I > 0) Then
    FileNameBMP.Text = Left(TheOutFile, I) + StrIndex
Else
    FileNameBMP.Text = TheOutFile + "." + StrIndex
End If

End Sub


Private Sub PaperNo_Click()
    LabelWidthHeight.Enabled = False
    TextWidthT.Enabled = False
    TextHeightT.Enabled = False
    If (PaperNo.ListIndex = 0) Then '640*480
        PaperHeight = 480
        PaperWidth = 640
        mmPaperHeight = PaperHeight * Screen.TwipsPerPixelY / 56.7
        mmPaperWidth = PaperWidth * Screen.TwipsPerPixelX / 56.7
    ElseIf (PaperNo.ListIndex = 1) Then '800*600
        PaperHeight = 600
        PaperWidth = 800
        mmPaperHeight = PaperHeight * Screen.TwipsPerPixelY / 56.7
        mmPaperWidth = PaperWidth * Screen.TwipsPerPixelX / 56.7
    ElseIf (PaperNo.ListIndex = 2) Then '1024*768
        PaperHeight = 768
        PaperWidth = 1024
        mmPaperHeight = PaperHeight * Screen.TwipsPerPixelY / 56.7
        mmPaperWidth = PaperWidth * Screen.TwipsPerPixelX / 56.7
    ElseIf (PaperNo.ListIndex = 3) Then
        PaperHeight = Screen.Height / Screen.TwipsPerPixelY
        PaperWidth = Screen.Width / Screen.TwipsPerPixelX
        mmPaperHeight = Screen.Height / 56.7
        mmPaperWidth = Screen.Width / 56.7
    ElseIf (PaperNo.ListIndex = PaperNo.ListCount - 1) Then '自定义
        LabelWidthHeight.Enabled = True
        TextWidthT.Enabled = True
        TextHeightT.Enabled = True
    Else
        '图纸长宽,单位mm
        mmPaperWidth = Val(Mid(PaperNo.List(PaperNo.ListIndex), 4, 3))
        mmPaperHeight = Val(Mid(PaperNo.List(PaperNo.ListIndex), 8, 3))
        '设置图片框长宽,单位twip,1mm=56.7twip
        PaperHeight = mmPaperHeight * 56.7 / Screen.TwipsPerPixelY
        PaperWidth = mmPaperWidth * 56.7 / Screen.TwipsPerPixelX
    End If
    TextWidthT.Text = PaperWidth
    TextHeightT.Text = PaperHeight
End Sub
Private Sub SaveBMPCancel_Click()
bOKCancel = False
Unload Me
End Sub

Private Sub SaveBMPOK_Click()
Dim I As Integer, StrIndex As String * 3

If (PaperNo.ListIndex = 0) Then '640*480
    PaperHeight = 480
    PaperWidth = 640
    mmPaperHeight = PaperHeight * Screen.TwipsPerPixelY / 56.7
    mmPaperWidth = PaperWidth * Screen.TwipsPerPixelX / 56.7
ElseIf (PaperNo.ListIndex = 1) Then '800*600
    PaperHeight = 600
    PaperWidth = 800
    mmPaperHeight = PaperHeight * Screen.TwipsPerPixelY / 56.7
    mmPaperWidth = PaperWidth * Screen.TwipsPerPixelX / 56.7
ElseIf (PaperNo.ListIndex = 2) Then '1024*768
    PaperHeight = 768
    PaperWidth = 1024
    mmPaperHeight = PaperHeight * Screen.TwipsPerPixelY / 56.7
    mmPaperWidth = PaperWidth * Screen.TwipsPerPixelX / 56.7
ElseIf (PaperNo.ListIndex = 3) Then
    PaperHeight = Screen.Height / Screen.TwipsPerPixelY
    PaperWidth = Screen.Width / Screen.TwipsPerPixelX
    mmPaperHeight = Screen.Height / 56.7
    mmPaperWidth = Screen.Width / 56.7
ElseIf (PaperNo.ListIndex = PaperNo.ListCount - 1) Then '自定义
    PaperWidth = TextWidthT.Text
    PaperHeight = TextHeightT.Text
    mmPaperHeight = PaperHeight * Screen.TwipsPerPixelY / 56.7
    mmPaperWidth = PaperWidth * Screen.TwipsPerPixelX / 56.7
Else
    '图纸长宽,单位mm
    mmPaperWidth = Val(Mid(PaperNo.List(PaperNo.ListIndex), 4, 3))
    mmPaperHeight = Val(Mid(PaperNo.List(PaperNo.ListIndex), 8, 3))
    '设置图片框长宽,单位twip,1mm=56.7twip
    PaperHeight = mmPaperHeight * 56.7 / Screen.TwipsPerPixelY
    PaperWidth = mmPaperWidth * 56.7 / Screen.TwipsPerPixelX
End If

If (OptionType(1).Value = True) Then
    StrIndex = "JPG"
ElseIf (OptionType(2).Value = True) Then
    StrIndex = "TIF"
ElseIf (OptionType(3).Value = True) Then
    StrIndex = "WMF"
Else
    StrIndex = "BMP"
End If

TheOutFile = FileNameBMP.Text
I = InStr(TheOutFile, ".")
If (I > 0) Then
    FileNameBMP.Text = Left(TheOutFile, I) + StrIndex
Else
    FileNameBMP.Text = TheOutFile + "." + StrIndex
End If
TheOutFile = FileNameBMP.Text
bOKCancel = True
Unload Me
End Sub