form1.frm

CAD转换工具 CAD转换工具 CAD转换工具 CAD转换工具

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "comctl32.ocx"
Begin VB.Form Form1 
   BackColor       =   &H80000005&
   Caption         =   "CADImage DLL Demo"
   ClientHeight    =   7695
   ClientLeft      =   165
   ClientTop       =   855
   ClientWidth     =   8370
   LinkTopic       =   "Form1"
   ScaleHeight     =   7695
   ScaleWidth      =   8370
   StartUpPosition =   3  'Windows Default
   Begin ComctlLib.ProgressBar pbBar 
      Height          =   375
      Left            =   4440
      TabIndex        =   1
      Top             =   7320
      Visible         =   0   'False
      Width           =   2295
      _ExtentX        =   4048
      _ExtentY        =   661
      _Version        =   327682
      Appearance      =   1
      Max             =   101
   End
   Begin ComctlLib.StatusBar sbBar 
      Align           =   2  'Align Bottom
      Height          =   375
      Left            =   0
      TabIndex        =   0
      Top             =   7320
      Width           =   8370
      _ExtentX        =   14764
      _ExtentY        =   661
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} 
         NumPanels       =   2
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            Bevel           =   0
            Object.Width           =   7056
            MinWidth        =   7056
            TextSave        =   ""
            Object.Tag             =   ""
         EndProperty
         BeginProperty Panel2 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            AutoSize        =   1
            Object.Width           =   7144
            TextSave        =   ""
            Object.Tag             =   ""
         EndProperty
      EndProperty
   End
   Begin MSComDlg.CommonDialog CD 
      Left            =   480
      Top             =   120
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Menu mFile 
      Caption         =   "File"
      Begin VB.Menu mLoad 
         Caption         =   "Load"
      End
      Begin VB.Menu bmp 
         Caption         =   "Save as bitmap"
      End
      Begin VB.Menu JPG 
         Caption         =   "Save as JPG"
      End
      Begin VB.Menu mPrint 
         Caption         =   "Print"
      End
      Begin VB.Menu mmiSep 
         Caption         =   "-"
      End
      Begin VB.Menu mmiExit 
         Caption         =   "Exit"
      End
   End
   Begin VB.Menu mmiView 
      Caption         =   "View"
      Begin VB.Menu mmiDrawPicture 
         Caption         =   "Draw CAD to picture"
      End
   End
   Begin VB.Menu mScale 
      Caption         =   "Scale"
      Begin VB.Menu m50 
         Caption         =   "50"
         Tag             =   "50"
      End
      Begin VB.Menu m100 
         Caption         =   "100"
         Tag             =   "100"
      End
      Begin VB.Menu m200 
         Caption         =   "200"
         Tag             =   "200"
      End
      Begin VB.Menu m500 
         Caption         =   "500"
         Tag             =   "500"
      End
      Begin VB.Menu m1000 
         Caption         =   "1000"
         Tag             =   "1000"
      End
   End
   Begin VB.Menu NLayers 
      Caption         =   "Layers"
   End
   Begin VB.Menu NLayouts 
      Caption         =   "Layouts"
   End
   Begin VB.Menu mmiOptions 
      Caption         =   "Options"
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Type GUID
     Data1 As Long
     Data2 As Integer
     Data3 As Integer
     Data4(7) As Byte
End Type

Private Type PicBmp
     Size As Long
     Type As Long
     hbmp As Long
     hPal As Long
     Reserved As Long
End Type

Private Declare Function SetMapMode Lib "gdi32" (ByVal hDC As Long, ByVal nMapMode As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
'Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnHandle As Long, ipic As IPicture) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetMapMode Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pbmi As BITMAPINFO, ByVal iUsage As Long, ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal hbmp As Long, ByVal uStartScan As Long, ByVal cScanLines As Long, lpvBits As Any, lpbmi As BITMAPINFO, ByVal fuColorUse As Long) As Long
Private Declare Function CreateDIBitmap Lib "gdi32" (ByVal hDC As Long, lpbmih As BITMAPINFOHEADER, ByVal fdwInit As Long, lpbInit As Any, ByRef lpbmi As BITMAPINFO, ByVal fuUsage As Long) As Long
Private Declare Function CreateBitmapIndirect Lib "gdi32" (ByRef lpBITMAP As BITMAP) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal cPlanes As Long, ByVal cBitsPerPel As Long, lpvBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal cBytes As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As GUID) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As CBoolean, riid As GUID, ppvObj As Any) As Long

Public Enum CBoolean ' enum members are Long data types
CFalse = 0
CTrue = 1
End Enum
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As CBoolean, ppstm As Any) As Long
Private Const S_OK = 0 ' indicates successful HRESULT
Private Const sIID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"

Const CBM_INIT = 4

Const MOVEFILE_REPLACE_EXISTING = &H1
Const FILE_ATTRIBUTE_TEMPORARY = &H100
Const FILE_BEGIN = 0
Const FILE_SHARE_READ = &H1
Const FILE_SHARE_WRITE = &H2
Const CREATE_NEW = 1
Const OPEN_EXISTING = 3
Const GENERIC_READ = &H80000000
Const GENERIC_WRITE = &H40000000
Const CREATE_ALWAYS = 1
Const FILE_ATTRIBUTE_NORMAL = &H80000000
Const GMEM_MOVEABLE = 2

Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Function GetClientRect Lib "user32.dll" (ByVal hWnd As Long, R As RECT) As Boolean
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateCAD Lib "CADImage.dll" (ByVal Window As Long, ByVal FileName As String) As Long
Private Declare Function CreateCADEx Lib "CADImage.dll" (ByVal Window As Long, ByVal FileName As String, ByVal Param As String) As Long
Private Declare Function CloseCAD Lib "CADImage.dll" (ByVal Handle As Long) As Long
Private Declare Function DrawCAD Lib "CADImage.dll" (ByVal Handle As Long, ByVal DC As Long, R As RECT) As Long
Private Declare Function DrawCADEx Lib "CADImage.dll" (ByVal Handle As Long, CdDraw As CADDRAW) As Long
Private Declare Function DrawCADtoBitmap Lib "CADImage.dll" (ByVal Handle As Long, CdDraw As CADDRAW) As Long
Private Declare Function DrawCADtoJpeg Lib "CADImage.dll" (ByVal Handle As Long, CdDraw As CADDRAW) As Long
Private Declare Function DrawCADtoGif Lib "CADImage.dll" (ByVal Handle As Long, CdDraw As CADDRAW) As Long
Private Declare Function GetBoxCAD Lib "CADImage.dll" (ByVal Handle As Long, AbsWidth As Single, AbsHeight As Single) As Long
Private Declare Function GetLastErrorCAD Lib "CADImage.dll" (ByVal Buf As String) As Long

Private Declare Function CADLayoutsCount Lib "CADImage.dll" (ByVal Handle As Long) As Integer
Private Declare Function CADLayoutName Lib "CADImage.dll" (ByVal Handle As Long, ByVal Index As Integer, ByVal Name As String, ByVal nSize As Integer) As Integer
Private Declare Function CADLayout Lib "CADImage.dll" (ByVal Handle As Long, ByVal Index As Integer) As Long
Private Declare Function DefaultLayoutIndex Lib "CADImage.dll" (ByVal Handle As Long) As Integer
Private Declare Function SetProgressProc Lib "CADImage.dll" (ByVal Proc As Long) As Integer
Private Declare Function StopLoading Lib "CADImage.dll" () As Integer
Private Declare Function DrawCADtoDIB Lib "CADImage.dll" (ByVal Handle As Long, ByRef R As RECT) As Long

Dim KX As Single
Dim KY As Single
Dim PreviousPoint As POINTAPI
Dim Offset As POINTAPI
Dim drag As Boolean
Dim FScale As Long

Private Sub bmp_Click()
Dim CrDraw As CADDRAW
Dim AbsWidth As Single
Dim AbsHeight As Single
Dim K As Double
Dim Hnd As Long, Size As Long, P As Long, FHnd As Long, Ret As Long

  If CADImage <> 0 Then
    CD.FileName = ""
    CD.Filter = "Bmp files (bmp)|*.bmp"
    CD.ShowSave
    GetBoxCAD CADImage, AbsWidth, AbsHeight
    If AbsHeight <> -1 Then
        GetClientRect Form1.hWnd, CrDraw.R
        If AbsWidth = 0 Then
          K = 1
        Else
          K = AbsHeight / AbsWidth
        End If
        CrDraw.Size = Len(CrDraw) 'size of CADDRAW
        CrDraw.R.top = 0
        CrDraw.R.left = 0
        CrDraw.R.bottom = CrDraw.R.right * K
        CrDraw.R.right = CrDraw.R.right * FScale / 100
        CrDraw.R.bottom = CrDraw.R.bottom * FScale / 100
        ' color mode
        ' 0 - color
        ' 1 - black and white
        ' 2 - glayscale mode
        CrDraw.DrawMode = 0 ' color mode
        Hnd = DrawCADtoBitmap(CADImage, CrDraw)
        If Hnd <> 0 Then
            Size = GlobalSize(Hnd)
            P = GlobalLock(Hnd)
            FHnd = CreateFile(CD.FileName, GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
            If FHnd <> 0 Then
                WriteFile FHnd, ByVal P&, Size, Ret, ByVal 0&
                CloseHandle FHnd
            End If
            GlobalUnlock Hnd
            GlobalFree Hnd
        End If
    End If
  End If
End Sub

Private Sub LoadPreview(ByVal FileName As String)
     Dim hInst As Long
     Dim hbmp  As Long
     Dim Pic As PicBmp
     
     Dim ipic As IPicture
     Dim IID_IDispatch As GUID
     Dim lRC As Long
     Dim bSize As Integer
     
     If SetBMSize_stdcall(200) Then
        hbmp = ReadCADInBMP(FileName, S)
        If hbmp <> 0 Then
             IID_IDispatch.Data1 = &H20400
             IID_IDispatch.Data4(0) = &HC0
             IID_IDispatch.Data4(7) = &H46
             Pic.Size = Len(Pic)
             Pic.Type = vbPicTypeBitmap
             Pic.hbmp = hbmp
             Pic.hPal = 0
             lRC = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, ipic)
             If lRC = 0 Then
                  Form3.Picture1 = ipic
                  Set ipic = Nothing
             Else
                  Call DeleteObject(hbmp)
             End If
             Form3.Show
        End If
     End If
End Sub

Private Sub Form_Initialize()
  BorderType = 1
  BorderSize = 1 / 8
End Sub

Private Sub Form_Load()
Dim R As RECT
    Offset.X = 0
    Offset.Y = 0