469,306 Members | 1,903 Online
Bytes | Developer Community
New Post

Home Posts Topics Members FAQ

Post your question to a community of 469,306 developers. It's quick & easy.

Stephen Lebans PDF code - set my own folder for saving the file

Hello,
I'm using Stephen Lebans code to create pdf file and it works great. Currently, if ShowSaveFileDialog is set to False, the file is automatically saved in "MyDocuments" folder. I want it to be automatically saved in a folder that i predefined. If someone knows how to do that, please tell me, there's so much code that i keep losing myself in it..
Sep 15 '10 #1
28 4392
NeoPa
32,173 Expert Mod 16PB
Where the folder is specified, add yours in instead. If you have the relevant code, and can say where the value is that you'd prefer to use, I'll see what I can suggest.
Sep 15 '10 #2
*i meant 'losing' of course
You are always the first one to answer my multiple threads:)
Well that's the whole problem, i can't find in code where exactly the folder is being set.. i would post the code, but it's really really long (mostly explanations). Can i maybe attach it as a text file?
Sep 15 '10 #3
NeoPa
32,173 Expert Mod 16PB
I don't really want all the code. I just want the code that is related to saving your file away, and any related code that may pertain to setting a default file location of course.

If you are unable to identify that, then you can post it all anyway, as the CODE tags ensure only one page or so is shown at any time. That way we also have line numbers to refer to later if necessary.
Sep 15 '10 #4
This is how i call the code
Expand|Select|Wrap|Line Numbers
  1. blRet = ConvertReportToPDF("rptEventProtocole", vbNullString, _
  2.     "Event" & eventNum & ".pdf", False, True, 150, "", "", 0, 0, &H81000)
  3.  
And here is the code (i omitted huge explanation blocks). Sure most of it is irrelevant, but.. if you'll have the patience
Expand|Select|Wrap|Line Numbers
  1. #Const ConDebug = 0    ' Set to 1 to force loading of DEBUG StrStorage.DLL
  2. #If (ConDebug = 1) Then
  3.  
  4. ' This is where I screwed up the Font Embedding. Forgot to declare PDFNoFontEmbedding as ByVal!
  5.     Public Declare Function ConvertUncompressedSnapshot Lib "C:\VisualCsource\Debug\StrStorage.dll" _
  6.     (ByVal UnCompressedSnapShotName As String, _
  7.     ByVal OutputPDFname As String, _
  8.     Optional ByVal CompressionLevel As Long = 0, _
  9.     Optional ByVal PasswordOpen As String = "", _
  10.     Optional ByVal PasswordOwner As String = "", _
  11.     Optional ByVal PasswordRestrictions As Long = 0, _
  12.     Optional ByVal PDFNoFontEmbedding As Long = 0, _
  13.     Optional ByVal PDFUnicodeFlags As Long = 0 _
  14.     ) As Boolean
  15.  
  16.     Public Declare Function DrawTableWindow Lib "C:\VisualCsource\Debug\StrStorage.dll" _
  17.     (ByVal TableName As String, _
  18.     ByVal Fields As String, _
  19.     ByVal NumFields As Long, _
  20.     ByVal Xpos As Double, _
  21.     ByVal Ypos As Double, _
  22.     ByVal Width As Double, _
  23.     ByVal Height As Double _
  24.     ) As Long
  25.  
  26.     Public Declare Function DrawLine Lib "C:\VisualCsource\Debug\StrStorage.dll" _
  27.     (ByVal Width As Double, _
  28.     ByVal Width1 As Double, _
  29.     ByVal Xpos As Double, _
  30.     ByVal Ypos As Double, _
  31.     ByVal Xpos1 As Double, _
  32.     ByVal Ypos1 As Double, _
  33.     ByVal Attrib As Long _
  34.     ) As Long
  35.  
  36.     Public Declare Function BeginPDF Lib "C:\VisualCsource\Debug\StrStorage.dll" _
  37.     (ByVal PDFfilename As String, _
  38.     ByVal PageWidth As Long, _
  39.     ByVal PageHeight As Long _
  40.     ) As Long
  41.  
  42.     Public Declare Function EndPDF Lib "C:\VisualCsource\Debug\StrStorage.dll" _
  43.     () As Long
  44.  
  45.     Public Declare Function MergePDFDocuments Lib "C:\VisualCsource\Debug\StrStorage.dll" _
  46.     (ByVal PDFMaster As String, _
  47.     ByVal PDFChild As String _
  48.     ) As Boolean
  49.  
  50. #Else
  51.  
  52. ' This is where I screwed up the Font Embedding. Forgot to declare PDFNoFontEmbedding as ByVal!
  53. Public Declare Function ConvertUncompressedSnapshot Lib "StrStorage.dll" _
  54.     (ByVal UnCompressedSnapShotName As String, _
  55.     ByVal OutputPDFname As String, _
  56.     Optional ByVal CompressionLevel As Long = 0, _
  57.     Optional ByVal PasswordOpen As String = "", _
  58.     Optional ByVal PasswordOwner As String = "", _
  59.     Optional ByVal PasswordRestrictions As Long = 0, _
  60.     Optional ByVal PDFNoFontEmbedding As Long = 0, _
  61.     Optional ByVal PDFUnicodeFlags As Long = 0 _
  62.     ) As Boolean
  63.  
  64.     Public Declare Function DrawTableWindow Lib "StrStorage.dll" _
  65.     (ByVal TableName As String, _
  66.     ByVal Fields As String, _
  67.     ByVal NumFields As Long, _
  68.     ByVal Xpos As Double, _
  69.     ByVal Ypos As Double, _
  70.     ByVal Width As Double, _
  71.     ByVal Height As Double _
  72.     ) As Long
  73.  
  74.     Public Declare Function DrawLine Lib "StrStorage.dll" _
  75.     (ByVal Width As Double, _
  76.     ByVal Width1 As Double, _
  77.     ByVal Xpos As Double, _
  78.     ByVal Ypos As Double, _
  79.     ByVal Xpos1 As Double, _
  80.     ByVal Ypos1 As Double, _
  81.     ByVal Attrib As Long _
  82.     ) As Long
  83.  
  84.     Public Declare Function BeginPDF Lib "StrStorage.dll" _
  85.     (ByVal PDFfilename As String, _
  86.     ByVal PageWidth As Long, _
  87.     ByVal PageHeight As Long _
  88.     ) As Long
  89.  
  90.     Public Declare Function EndPDF Lib "StrStorage.dll" _
  91.     () As Long
  92.  
  93.     Public Declare Function MergePDFDocuments Lib "StrStorage.dll" _
  94.     (ByVal PDFMaster As String, _
  95.     ByVal PDFChild As String _
  96.     ) As Boolean
  97.  
  98. #End If
  99.  
  100. ' For debugging with Visual C++
  101. 'Lib "C:\VisualCsource\Debug\StrStorage.dll"
  102.  
  103. Private Declare Function ShellExecuteA Lib "shell32.dll" _
  104. (ByVal hwnd As Long, ByVal lpOperation As String, _
  105. ByVal lpFile As String, ByVal lpParameters As String, _
  106. ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
  107.  
  108. Private Declare Function LoadLibrary Lib "kernel32" _
  109. Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
  110.  
  111. Private Declare Function FreeLibrary Lib "kernel32" _
  112. (ByVal hLibModule As Long) As Long
  113.  
  114. Private Declare Function GetTempPath Lib "kernel32" _
  115. Alias "GetTempPathA" (ByVal nBufferLength As Long, _
  116. ByVal lpBuffer As String) As Long
  117.  
  118. Private Declare Function GetTempFileName _
  119. Lib "kernel32" Alias "GetTempFileNameA" _
  120. (ByVal lpszPath As String, _
  121. ByVal lpPrefixString As String, _
  122. ByVal wUnique As Long, _
  123. ByVal lpTempFileName As String) As Long
  124.  
  125. Private Declare Function SetupDecompressOrCopyFile _
  126. Lib "setupAPI" _
  127. Alias "SetupDecompressOrCopyFileA" ( _
  128. ByVal SourceFileName As String, _
  129. ByVal TargetFileName As String, _
  130. ByVal CompressionType As Integer) As Long
  131.  
  132. Private Declare Function SetupGetFileCompressionInfo _
  133. Lib "setupAPI" _
  134. Alias "SetupGetFileCompressionInfoA" ( _
  135. ByVal SourceFileName As String, _
  136. TargetFileName As String, _
  137. SourceFileSize As Long, _
  138. DestinationFileSize As Long, _
  139. CompressionType As Integer _
  140. ) As Long
  141.  
  142. 'Compression types
  143. Private Const FILE_COMPRESSION_NONE = 0
  144. Private Const FILE_COMPRESSION_WINLZA = 1
  145. Private Const FILE_COMPRESSION_MSZIP = 2
  146.  
  147. Private Const Pathlen = 256
  148. Private Const MaxPath = 256
  149.  
  150. ' Note: I converted the Enums to Constants to allow for use in Access 97.
  151.  
  152. 'Enum TDocumentInfo 'Coming Soon!
  153.  '  diAuthor
  154.  '  diCreator
  155.  '  diKeywords
  156.  '  diProducer
  157.  '  diSubject
  158.  '  diTitle
  159.  '  diCompany
  160.  '  diPDFX_Ver ' GetInDocInfo() only -> The PDF/X version is set by SetPDFVersion()!
  161.  '  diCustom   ' User defined key
  162. 'End Enum
  163.  
  164. 'Enum TKeyLen
  165.    Public Const kl40bit = 0    '  40 bit RC4 encryption (Acrobat 3 or higher)
  166.    Public Const kl128bit = 1 ' 128 bit RC4 encryption (Acrobat 5 or higher)
  167.    Public Const kl128bitEx = 2 ' 128 bit RC4 encryption (Acrobat 6 or higher)
  168. 'End Enum
  169.  
  170. 'Enum TRestrictions
  171.   Public Const rsDenyNothing = 0
  172.   Public Const rsDenyAll = 3900
  173.   Public Const rsPrint = 4
  174.   Public Const rsModify = 8
  175.   Public Const rsCopyObj = 16
  176.   Public Const rsAddObj = 32
  177.   ' 128 bit encryption only -> these values are ignored if 40 bit encryption is used
  178.   Public Const rsFillInFormFields = 256
  179.   Public Const rsExtractObj = 512
  180.   Public Const rsAssemble = 1024
  181.   Public Const rsPrintHighRes = 2048
  182.   Public Const rsExlMetadata = 4096      ' PDF 1.5 -> can be used with kl128bitEx only
  183. 'End Enum
  184.  
  185. Public Type POINTAPI
  186.    X As Long
  187.    Y As Long
  188. End Type
  189.  
  190. Public Type RECTL
  191.    Left As Long
  192.    Top As Long
  193.    Right As Long
  194.    Bottom As Long
  195. End Type
  196.  
  197. Public Const AAAlength = 12
  198. Public Const FFFlength = 8
  199. Public Const Padding = 12
  200. Public Const NameLengthMax = 128
  201. ' 64 Char MAX for a DAO Table Name * 2 = Unicode
  202.  
  203. Public Type RelBlob
  204.     Sig As Long
  205.     AAAs(1 To AAAlength) As Byte
  206.     RelWinX1  As Long
  207.     RelWinY1 As Long
  208.     RelWinX2  As Long
  209.     RelWinY2 As Long
  210.     Blank As Long
  211.     FFFs(1 To FFFlength) As Byte
  212.     ClientRectX As Long
  213.     ClientRectY As Long
  214.     'Pad(1 To Padding) As Byte
  215.     ' These next 2 long values represent the Horiz and Vert ScrollBar positions(if any).
  216.     ' These values must be added to the window coordinates stored in this Blob.
  217.     ScrollBarYoffset As Long
  218.     ScrollBarXoffset As Long
  219.     Pad1 As Long
  220.     NumWindows As Long
  221. End Type
  222.  
  223. Public Type RelWindow
  224.     RelWinX1  As Long
  225.     RelWinY1 As Long
  226.     RelWinX2  As Long
  227.     RelWinY2 As Long
  228.     Junk As Long
  229.     WinName As String * NameLengthMax
  230.     Junk1 As Long
  231.     WinNameMaster As String * NameLengthMax
  232.     'Pad(1 To Padding) As Byte
  233.     Junk2 As Long
  234. End Type
  235.  
  236. Public Type RelWindowMin
  237.     RelWinX1  As Long
  238.     RelWinY1 As Long
  239.     RelWinX2  As Long
  240.     RelWinY2 As Long
  241.     Column As Long
  242.     WinName As String
  243. End Type
  244.  
  245. Public Declare Function ScreenToClient Lib "user32" _
  246. (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
  247.  
  248. Public Declare Function FindWindowEx Lib "user32" Alias _
  249. "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
  250. ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
  251.  
  252. Public Declare Function apiGetWindow Lib "user32" _
  253. Alias "GetWindow" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
  254.  
  255. Public Declare Function GetWindowRect Lib "user32" _
  256. (ByVal hwnd As Long, lpRect As RECTL) As Long
  257.  
  258. Public Declare Function SetWindowPos Lib "user32" _
  259. (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, _
  260. ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
  261.  
  262. Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
  263. (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
  264.  
  265. Public Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
  266. (Destination As Any, Source As Any, ByVal Length As Long)
  267.  
  268. ' Create an Information Context
  269. Private Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
  270. (ByVal lpDriverName As String, ByVal lpDeviceName As String, _
  271. ByVal lpOutput As String, lpInitData As Any) As Long
  272.  
  273. Private Declare Function apiGetDeviceCaps Lib "gdi32" _
  274. Alias "GetDeviceCaps" (ByVal hDC As Long, ByVal nIndex As Long) As Long
  275.  
  276. Private Declare Function apiDeleteDC Lib "gdi32" _
  277.   Alias "DeleteDC" (ByVal hDC As Long) As Long
  278.  
  279. ' SetWindowPos() Constants
  280. Public Const SWP_SHOWWINDOW = &H40
  281.  
  282. ' GetWindow() Constants
  283. Public Const GW_HWNDNEXT = 2
  284. Public Const GW_CHILD = 5
  285.  
  286. '  Device Parameters for GetDeviceCaps()
  287. Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X
  288. Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y
  289.  
  290. ' ***********************************************
  291. '       Font, DC and TextWidth stuff
  292.  
  293. Private Type RECT
  294.         Left As Long
  295.         Top As Long
  296.         Right As Long
  297.         Bottom As Long
  298. End Type
  299.  
  300. Private Const LF_FACESIZE = 32
  301.  
  302. Private Type LOGFONT
  303.         lfHeight As Long
  304.         lfWidth As Long
  305.         lfEscapement As Long
  306.         lfOrientation As Long
  307.         lfWeight As Long
  308.         lfItalic As Byte
  309.         lfUnderline As Byte
  310.         lfStrikeOut As Byte
  311.         lfCharSet As Byte
  312.         lfOutPrecision As Byte
  313.         lfClipPrecision As Byte
  314.         lfQuality As Byte
  315.         lfPitchAndFamily As Byte
  316.         lfFaceName As String * LF_FACESIZE
  317. End Type
  318.  
  319. Private Type TEXTMETRIC
  320.         tmHeight As Long
  321.         tmAscent As Long
  322.         tmDescent As Long
  323.         tmInternalLeading As Long
  324.         tmExternalLeading As Long
  325.         tmAveCharWidth As Long
  326.         tmMaxCharWidth As Long
  327.         tmWeight As Long
  328.         tmOverhang As Long
  329.         tmDigitizedAspectX As Long
  330.         tmDigitizedAspectY As Long
  331.         tmFirstChar As Byte
  332.         tmLastChar As Byte
  333.         tmDefaultChar As Byte
  334.         tmBreakChar As Byte
  335.         tmItalic As Byte
  336.         tmUnderlined As Byte
  337.         tmStruckOut As Byte
  338.         tmPitchAndFamily As Byte
  339.         tmCharSet As Byte
  340. End Type
  341.  
  342. Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" _
  343. (ByVal hDC As Long, lpMetrics As TEXTMETRIC) As Long
  344.  
  345. Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _
  346.         "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
  347.  
  348. Private Declare Function apiSelectObject Lib "gdi32" Alias "SelectObject" _
  349. (ByVal hDC As Long, _
  350. ByVal hObject As Long) As Long
  351.  
  352. Private Declare Function apiDeleteObject Lib "gdi32" _
  353.   Alias "DeleteObject" (ByVal hObject As Long) As Long
  354.  
  355. Private Declare Function apiMulDiv Lib "kernel32" Alias "MulDiv" _
  356. (ByVal nNumber As Long, _
  357. ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
  358.  
  359. Private Declare Function apiGetDC Lib "user32" _
  360.   Alias "GetDC" (ByVal hwnd As Long) As Long
  361.  
  362. Private Declare Function apiReleaseDC Lib "user32" _
  363.  Alias "ReleaseDC" (ByVal hwnd As Long, _
  364.  ByVal hDC As Long) As Long
  365.  
  366. Private Declare Function apiDrawText Lib "user32" Alias "DrawTextA" _
  367. (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, _
  368. lpRect As RECT, ByVal wFormat As Long) As Long
  369.  
  370. Private Declare Function CreateDCbyNum Lib "gdi32" Alias "CreateDCA" _
  371. (ByVal lpDriverName As String, ByVal lpDeviceName As String, _
  372. ByVal lpOutput As Long, ByVal lpInitData As Long) As Long  'DEVMODE) As Long
  373.  
  374. Declare Function GetProfileString Lib "kernel32" _
  375.    Alias "GetProfileStringA" _
  376.   (ByVal lpAppName As String, _
  377.    ByVal lpKeyName As String, _
  378.    ByVal lpDefault As String, _
  379.    ByVal lpReturnedString As String, _
  380.    ByVal nSize As Long) As Long
  381.  
  382. ' CONSTANTS
  383. Private Const TWIPSPERINCH = 1440
  384. ' Used to ask System for the Logical pixels/inch in X & Y axis
  385. 'Private Const LOGPIXELSY = 90
  386. 'Private Const LOGPIXELSX = 88
  387.  
  388. ' DrawText() Format Flags
  389. Private Const DT_TOP = &H0
  390. Private Const DT_LEFT = &H0
  391. Private Const DT_CALCRECT = &H400
  392. Private Const DT_WORDBREAK = &H10
  393. Private Const DT_EXTERNALLEADING = &H200
  394. Private Const DT_EDITCONTROL = &H2000&
  395. Private Const DT_NOCLIP = &H100
  396.  
  397. ' Font stuff
  398. Private Const OUT_DEFAULT_PRECIS = 0
  399. Private Const OUT_STRING_PRECIS = 1
  400. Private Const OUT_CHARACTER_PRECIS = 2
  401. Private Const OUT_STROKE_PRECIS = 3
  402. Private Const OUT_TT_PRECIS = 4
  403. Private Const OUT_DEVICE_PRECIS = 5
  404. Private Const OUT_RASTER_PRECIS = 6
  405. Private Const OUT_TT_ONLY_PRECIS = 7
  406. Private Const OUT_OUTLINE_PRECIS = 8
  407.  
  408. Private Const CLIP_DEFAULT_PRECIS = 0
  409. Private Const CLIP_CHARACTER_PRECIS = 1
  410. Private Const CLIP_STROKE_PRECIS = 2
  411. Private Const CLIP_MASK = &HF
  412. Private Const CLIP_LH_ANGLES = 16
  413. Private Const CLIP_TT_ALWAYS = 32
  414. Private Const CLIP_EMBEDDED = 128
  415.  
  416. Private Const DEFAULT_QUALITY = 0
  417. Private Const DRAFT_QUALITY = 1
  418. Private Const PROOF_QUALITY = 2
  419.  
  420. Private Const DEFAULT_PITCH = 0
  421. Private Const FIXED_PITCH = 1
  422. Private Const VARIABLE_PITCH = 2
  423.  
  424. Private Const ANSI_CHARSET = 0
  425. Private Const DEFAULT_CHARSET = 1
  426. Private Const SYMBOL_CHARSET = 2
  427. Private Const SHIFTJIS_CHARSET = 128
  428. Private Const HANGEUL_CHARSET = 129
  429. Private Const CHINESEBIG5_CHARSET = 136
  430. Private Const OEM_CHARSET = 255
  431.  
  432. ' ***********************************************
  433. ' Allow user to set FileName instead
  434. ' of using API Temp Filename or
  435. ' popping File Dialog Window
  436. Private mSaveFileName As String
  437.  
  438. ' Full path and name of uncompressed SnapShot file
  439. Private mUncompressedSnapFile As String
  440.  
  441. ' Name of the Report we ' working with
  442. Private mReportName As String
  443.  
  444. ' Instance returned from LoadLibrary calls
  445. Private hLibDynaPDF As Long
  446. Private hLibStrStorage As Long
  447.  
  448. Public Function ConvertReportToPDF( _
  449. Optional RptName As String = "", _
  450. Optional SnapshotName As String = "", _
  451. Optional OutputPDFname As String = "", _
  452. Optional ShowSaveFileDialog As Boolean = False, _
  453. Optional StartPDFViewer As Boolean = True, _
  454. Optional CompressionLevel As Long = 0, _
  455. Optional PasswordOpen As String = "", _
  456. Optional PasswordOwner As String = "", _
  457. Optional PasswordRestrictions As Long = 0, _
  458. Optional PDFNoFontEmbedding As Long = 0, _
  459. Optional PDFUnicodeFlags As Long = &H1000 _
  460. ) As Boolean
  461.  
  462. ' RptName is the name of a report contained within this MDB
  463. ' SnapshotName is the name of an existing Snapshot file
  464. ' OutputPDFname is the name you select for the output PDF file
  465. ' ShowSaveFileDialog is a boolean param to specify whether or not to display
  466. ' the standard windows File Dialog window to select an exisiting Snapshot file
  467. ' CompressionLevel - not hooked up yet
  468. ' PasswordOwner  - not hooked up yet
  469. ' PasswordOpen - not hooked up yet
  470. ' PasswordRestrictions - not hooked up yet
  471. ' PDFNoFontEmbedding - Do not Embed fonts in PDF. Set to 1 to stop the
  472. ' default process of embedding all fonts in the output PDF. If you are
  473. ' using ONLY - any of the standard Windows fonts
  474. ' using ONLY - any of the standard 14 Fonts natively supported by the PDF spec
  475. 'The 14 Standard Fonts
  476. 'All version of Adobe's Acrobat support 14 standard fonts. These fonts are always available
  477. 'independent whether they're embedded or not.
  478. 'Family name PostScript name Style
  479. 'Courier Courier fsNone
  480. 'Courier Courier-Bold fsBold
  481. 'Courier Courier-Oblique fsItalic
  482. 'Courier Courier-BoldOblique fsBold + fsItalic
  483. 'Helvetica Helvetica fsNone
  484. 'Helvetica Helvetica-Bold fsBold
  485. 'Helvetica Helvetica-Oblique fsItalic
  486. 'Helvetica Helvetica-BoldOblique fsBold + fsItalic
  487. 'Times Times-Roman fsNone
  488. 'Times Times-Bold fsBold
  489. 'Times Times-Italic fsItalic
  490. 'Times Times-BoldItalic fsBold + fsItalic
  491. 'Symbol Symbol fsNone, other styles are emulated only
  492. 'ZapfDingbats ZapfDingbats fsNone, other styles are emulated only
  493.  
  494. Dim s As String
  495. Dim blRet As Boolean
  496. ' Let's see if the DynaPDF.DLL is available.
  497. blRet = LoadLib()
  498. If blRet = False Then
  499.     ' Cannot find DynaPDF.dll or StrStorage.dll file
  500.     Exit Function
  501. End If
  502.  
  503. On Error GoTo ERR_CREATSNAP
  504.  
  505. Dim strPath  As String
  506. Dim strPathandFileName  As String
  507. Dim strEMFUncompressed As String
  508.  
  509. Dim sOutFile As String
  510. Dim lngRet As Long
  511.  
  512. ' Init our string buffer
  513. strPath = Space(Pathlen)
  514.  
  515. 'Save the ReportName to a local var
  516. mReportName = RptName
  517.  
  518. ' Let's kill any existing Temp SnapShot file
  519. If Len(mUncompressedSnapFile & vbNullString) > 0 Then
  520.     Kill mUncompressedSnapFile
  521.     mUncompressedSnapFile = ""
  522. End If
  523.  
  524. ' If we have been passed the name of a Snapshot file then
  525. ' skip the Snapshot creation process below
  526. If Len(SnapshotName & vbNullString) = 0 Then
  527.  
  528.     ' Make sure we were passed a ReportName
  529.     If Len(RptName & vbNullString) = 0 Then
  530.         ' No valid parameters - FAIL AND EXIT!!
  531.         ConvertReportToPDF = ""
  532.         Exit Function
  533.     End If
  534.  
  535.     ' Get the Systems Temp path
  536.     ' Returns Length of path(num characters in path)
  537.     lngRet = GetTempPath(Pathlen, strPath)
  538.     ' Chop off NULLS and trailing "\"
  539.     strPath = Left(strPath, lngRet) & Chr(0)
  540.  
  541.     ' Now need a unique Filename
  542.     ' locked from a previous aborted attemp.
  543.     ' Needs more work!
  544.     strPathandFileName = GetUniqueFilename(strPath, "SNP" & Chr(0), "snp")
  545.  
  546.     ' Export the selected Report to SnapShot format
  547.     DoCmd.OutputTo acOutputReport, RptName, "SnapshotFormat(*.snp)", _
  548.        strPathandFileName
  549.     ' Make sure the process has time to complete
  550.     DoEvents
  551. Else
  552.     strPathandFileName = SnapshotName
  553. End If
  554.  
  555. ' Let's decompress into same filename but change type to ".tmp"
  556. 'strEMFUncompressed = Mid(strPathandFileName, 1, Len(strPathandFileName) - 3)
  557. 'strEMFUncompressed = strEMFUncompressed & "tmp"
  558. Dim sPath As String * 512
  559. lngRet = GetTempPath(512, sPath)
  560.  
  561. strEMFUncompressed = GetUniqueFilename(sPath, "SNP", "tmp")
  562.  
  563. lngRet = SetupDecompressOrCopyFile(strPathandFileName, strEMFUncompressed, 0&)
  564.  
  565. If lngRet <> 0 Then
  566.     Err.Raise vbObjectError + 525, "ConvertReportToPDF.SetupDecompressOrCopyFile", _
  567.     "Sorry...cannot Decompress SnapShot File" & vbCrLf & _
  568.     "Please select a different Report to Export"
  569. End If
  570.  
  571. ' Set our uncompressed SnapShot file name var
  572. mUncompressedSnapFile = strEMFUncompressed
  573.  
  574. ' Remember to Cleanup our Temp SnapShot File if we were NOT passed the
  575. ' Snapshot file as the optional param
  576. If Len(SnapshotName & vbNullString) = 0 Then
  577.     Kill strPathandFileName
  578. End If
  579.  
  580. ' Do we name output file the same as the input file name
  581. ' and simply change the file extension to .PDF or
  582. ' do we show the File Save Dialog
  583. If ShowSaveFileDialog = False Then
  584.  
  585.     ' let's decompress into same filename but change type to ".tmp"
  586.     ' But first let's see if we were passed an output PDF file name
  587.     If Len(OutputPDFname & vbNullString) = 0 Then
  588.         sOutFile = Mid(strPathandFileName, 1, Len(strPathandFileName) - 3)
  589.         sOutFile = sOutFile & "PDF"
  590.     Else
  591.         sOutFile = OutputPDFname
  592.     End If
  593. Else
  594.     ' Call File Save Dialog
  595.     sOutFile = fFileDialog()
  596.     If Len(sOutFile & vbNullString) = 0 Then
  597.         Exit Function
  598.     End If
  599. End If
  600.  
  601. ' Call our function in the StrStorage DLL
  602. ' Note the Compression and Password params are not hooked up yet.
  603. blRet = ConvertUncompressedSnapshot(mUncompressedSnapFile, sOutFile, _
  604. CompressionLevel, PasswordOpen, PasswordOwner, PasswordRestrictions, PDFNoFontEmbedding, PDFUnicodeFlags)
  605.  
  606. If blRet = False Then
  607. Err.Raise vbObjectError + 526, "ConvertReportToPDF.ConvertUncompressedSnaphot", _
  608.     "Sorry...damaged SnapShot File" & vbCrLf & _
  609.     "Please select a different Report to Export"
  610. End If
  611.  
  612. ' Do we open new PDF in registered PDF viewer on this system?
  613. If StartPDFViewer = True Then
  614.  ShellExecuteA Application.hWndAccessApp, "open", sOutFile, vbNullString, vbNullString, 1
  615. End If
  616.  
  617. ' Success
  618. ConvertReportToPDF = True
  619.  
  620. EXIT_CREATESNAP:
  621.  
  622. ' Let's kill any existing Temp SnapShot file
  623. 'If Len(mUncompressedSnapFile & vbNullString) > 0 Then
  624.      On Error Resume Next
  625.    Kill mUncompressedSnapFile
  626.     mUncompressedSnapFile = ""
  627. 'End If
  628.  
  629. ' If we aready loaded then free the library
  630. If hLibStrStorage <> 0 Then
  631.     hLibStrStorage = FreeLibrary(hLibStrStorage)
  632. End If
  633.  
  634. If hLibDynaPDF <> 0 Then
  635.     hLibDynaPDF = FreeLibrary(hLibDynaPDF)
  636. End If
  637.  
  638. Exit Function
  639.  
  640. ERR_CREATSNAP:
  641. MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
  642. mUncompressedSnapFile = ""
  643. ConvertReportToPDF = False
  644. Resume EXIT_CREATESNAP
  645.  
  646. End Function
  647.  
  648. Private Function LoadLib() As Boolean
  649. Dim s As String
  650. Dim blRet As Boolean
  651.  
  652. On Error Resume Next
  653.  
  654. ' *** Please Note ***
  655. ' If you are going to process many reports at once then to improve performance you
  656. ' should only call LoadLib once.
  657.  
  658. ' May 16/2008
  659. ' Always look in the folder where this MDB resides First before checking the System folder.
  660.  
  661. LoadLib = False
  662.  
  663. ' If we aready loaded then free the library
  664. If hLibDynaPDF <> 0 Then
  665.     hLibDynaPDF = FreeLibrary(hLibDynaPDF)
  666. End If
  667.  
  668.  
  669. ' Our error string
  670. s = "Sorry...cannot find the DynaPDF.dll file" & vbCrLf
  671. s = s & "Please copy the DynaPDF.dll file into the same folder as this Access MDB or your Windows System32 folder."
  672.  
  673. ' OK Try to load the DLL assuming it is in the same folder as this MDB.
  674. ' CurrentDB works with both A97 and A2K or higher
  675. hLibDynaPDF = LoadLibrary(CurrentDBDir() & "DynaPDF.dll")
  676.  
  677. If hLibDynaPDF = 0 Then
  678.     ' OK Try to load the DLL assuming it is in the Window System folder
  679.     hLibDynaPDF = LoadLibrary("DynaPDF.dll")
  680. End If
  681.  
  682. If hLibDynaPDF = 0 Then
  683.     MsgBox s, vbOKOnly, "MISSING DynaPDF.dll FILE"
  684.     LoadLib = False
  685.     Exit Function
  686. End If
  687.  
  688. '' ** Commented out for Debugging only - Must be active
  689. '' ***************************************************************************
  690. '
  691. ' Load StrStorage.DLL
  692. ' If we aready loaded then free the library
  693. If hLibStrStorage <> 0 Then
  694.     hLibStrStorage = FreeLibrary(hLibStrStorage)
  695. End If
  696.  
  697. ' Our error string
  698. s = "Sorry...cannot find the StrStorage.dll file" & vbCrLf
  699. s = s & "Please copy the StrStorage.dll file into the same folder as this Access MDB or your Windows System32 folder."
  700.  
  701. ' OK Try to load the DLL assuming it is in the same folder as this MDB.
  702. ' CurrentDB works with both A97 and A2K or higher
  703. hLibStrStorage = LoadLibrary(CurrentDBDir() & "StrStorage.dll")
  704.  
  705. If hLibStrStorage = 0 Then
  706.     ' OK Try to load the DLL assuming it is in the Window System folder
  707.     hLibStrStorage = LoadLibrary("StrStorage.dll")
  708. End If
  709.  
  710. If hLibStrStorage = 0 Then
  711.     MsgBox s, vbOKOnly, "MISSING StrStorage.dll FILE"
  712.     LoadLib = False
  713.     Exit Function
  714. End If
  715.  
  716. ' RETURN SUCCESS
  717. LoadLib = True
  718. End Function
  719.  
  720. '******************** Code Begin ****************
  721. 'Code courtesy of
  722. 'Terry Kreft & Ken Getz
  723. '
  724. Private Function CurrentDBDir() As String
  725. Dim strDbPath As String
  726. Dim strDBFile As String
  727.     strDbPath = CurrentDb.Name
  728.     strDBFile = Dir(strDbPath)
  729.     CurrentDBDir = Left$(strDbPath, Len(strDbPath) - Len(strDBFile))
  730. End Function
  731. '******************** Code End ****************
  732.  
  733. Private Function GetUniqueFilename(Optional path As String = "", _
  734. Optional Prefix As String = "", _
  735. Optional UseExtension As String = "") _
  736. As String
  737.  
  738. ' originally Posted by Terry Kreft
  739. ' to: comp.Databases.ms -Access
  740. ' Subject:  Re: Creating Unique filename ??? (Dev code)
  741. ' Date: 01/15/2000
  742. ' Author: Terry Kreft <terry.kreft@mps.co.uk>
  743.  
  744. ' SL Note: Input strings must be NULL terminated.
  745. ' Here it is done by the calling function.
  746.  
  747.   Dim wUnique As Long
  748.   Dim lpTempFileName As String
  749.   Dim lngRet As Long
  750.  
  751.   wUnique = 0
  752.   If path = "" Then path = CurDir
  753.   lpTempFileName = String(MaxPath, 0)
  754.   lngRet = GetTempFileName(path, Prefix, _
  755.                             wUnique, lpTempFileName)
  756.  
  757.   lpTempFileName = Left(lpTempFileName, _
  758.                         InStr(lpTempFileName, Chr(0)) - 1)
  759.   Call Kill(lpTempFileName)
  760.   If Len(UseExtension) > 0 Then
  761.     lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
  762.   End If
  763.   GetUniqueFilename = lpTempFileName
  764. End Function
  765.  
  766. Private Function fFileDialog() As String
  767. ' Calls the API File Save Dialog Window
  768. ' Returns full path to new File
  769.  
  770. On Error GoTo Err_fFileDialog
  771. ' Call the File Common Dialog Window
  772. Dim clsDialog As Object
  773. Dim strTemp As String
  774. Dim strFname As String
  775.  
  776. Set clsDialog = New clsCommonDialog
  777.  
  778. ' Fill in our structure
  779. ' I'll leave in how to select Gif and Jpeg to
  780. ' show you how to build the Filter in case you want
  781. ' to use this code in another project.
  782. clsDialog.Filter = "PDF (*.PDF)" & Chr$(0) & "*.PDF" & Chr$(0)
  783. 'clsDialog.Filter = clsDialog.Filter & "Gif (*.GIF)" & Chr$(0) & "*.GIF" & Chr$(0)
  784. 'clsDialog.Filter = "ALL (*.*)" & Chr$(0) & "*.*" & Chr$(0)
  785. clsDialog.hDC = 0
  786. clsDialog.MaxFileSize = 256
  787. clsDialog.Max = 256
  788. clsDialog.FileTitle = vbNullString
  789. clsDialog.DialogTitle = "Please Select a path and Enter a Name for the PDF File"
  790. clsDialog.InitDir = vbNullString
  791. clsDialog.DefaultExt = vbNullString
  792.  
  793. ' Display the File Dialog
  794. clsDialog.ShowSave
  795.  
  796. ' See if user clicked Cancel or even selected
  797. ' the very same file already selected
  798. strFname = clsDialog.FileName
  799. 'If Len(strFname & vbNullString) = 0 Then
  800. ' Raise the exception
  801.  ' Err.Raise vbObjectError + 513, "clsPrintToFit.fFileDialog", _
  802.   '"Please type in a Name for a New File"
  803. 'End If
  804.  
  805. ' Return File Path and Name
  806. fFileDialog = strFname
  807.  
  808. Exit_fFileDialog:
  809.  
  810. Err.Clear
  811. Set clsDialog = Nothing
  812. Exit Function
  813.  
  814. Err_fFileDialog:
  815. fFileDialog = ""
  816. MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
  817. Resume Exit_fFileDialog
  818.  
  819. End Function
  820.  
  821. Public Function fFileDialogSnapshot() As String
  822. ' Calls the API File Open Dialog Window
  823. ' Returns full path to existing Snapshot File
  824.  
  825. On Error GoTo Err_fFileDialog
  826.  
  827. ' Call the File Common Dialog Window
  828. Dim clsDialog As Object
  829. Dim strTemp As String
  830. Dim strFname As String
  831.  
  832. Set clsDialog = New clsCommonDialog
  833.  
  834. ' Fill in our structure
  835. ' I'll leave in how to select Gif and Jpeg to
  836. ' show you how to build the Filter in case you want
  837. ' to use this code in another project.
  838. clsDialog.Filter = "SNAPSHOT (*.SNP)" & Chr$(0) & "*.SNP" & Chr$(0)
  839. 'clsDialog.Filter = "ALL (*.*)" & Chr$(0) & "*.*" & Chr$(0)
  840. clsDialog.hDC = 0
  841. clsDialog.MaxFileSize = 256
  842. clsDialog.Max = 256
  843. clsDialog.FileTitle = vbNullString
  844. clsDialog.DialogTitle = "Please Select a Snapshot File"
  845. clsDialog.InitDir = vbNullString
  846. clsDialog.DefaultExt = vbNullString
  847.  
  848. ' Display the File Dialog
  849. clsDialog.ShowOpen
  850.  
  851. ' See if user clicked Cancel or even selected
  852. ' the very same file already selected
  853. strFname = clsDialog.FileName
  854. If Len(strFname & vbNullString) = 0 Then
  855. ' Do nothing. Add your desired error logic here.
  856. End If
  857.  
  858. ' Return File Path and Name
  859. fFileDialogSnapshot = strFname
  860.  
  861. Exit_fFileDialog:
  862.  
  863. Err.Clear
  864. Set clsDialog = Nothing
  865. Exit Function
  866.  
  867. Err_fFileDialog:
  868. fFileDialogSnapshot = ""
  869. MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
  870. Resume Exit_fFileDialog
  871.  
  872. End Function
  873.  
  874. Public Function fFileDialogSavePDFname() As String
  875. ' Calls the API File Open Dialog Window
  876. ' Returns full path to existing Snapshot File
  877.  
  878. On Error GoTo Err_fFileDialog
  879.  
  880. ' Call the File Common Dialog Window
  881. Dim clsDialog As Object
  882. Dim strTemp As String
  883. Dim strFname As String
  884.  
  885. Set clsDialog = New clsCommonDialog
  886.  
  887. ' Fill in our structure
  888. ' I'll leave in how to select Gif and Jpeg to
  889. ' show you how to build the Filter in case you want
  890. ' to use this code in another project.
  891. clsDialog.Filter = "PDF (*.PDF)" & Chr$(0) & "*.PDF" & Chr$(0)
  892. 'clsDialog.Filter = "ALL (*.*)" & Chr$(0) & "*.*" & Chr$(0)
  893. clsDialog.hDC = 0
  894. clsDialog.MaxFileSize = 256
  895. clsDialog.Max = 256
  896. clsDialog.FileTitle = vbNullString
  897. clsDialog.DialogTitle = "Please Select a name for the PDF File"
  898. clsDialog.InitDir = vbNullString
  899. clsDialog.DefaultExt = vbNullString
  900.  
  901. ' Display the File Dialog
  902. clsDialog.ShowOpen
  903.  
  904. ' See if user clicked Cancel or even selected
  905. ' the very same file already selected
  906. strFname = clsDialog.FileName
  907. If Len(strFname & vbNullString) = 0 Then
  908. ' Do nothing. Add your desired error logic here.
  909. End If
  910.  
  911. ' Return File Path and Name
  912. fFileDialogSavePDFname = strFname
  913.  
  914. Exit_fFileDialog:
  915.  
  916. Err.Clear
  917. Set clsDialog = Nothing
  918. Exit Function
  919.  
  920. Err_fFileDialog:
  921. fFileDialogSavePDFname = ""
  922. MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
  923. Resume Exit_fFileDialog
  924.  
  925. End Function
  926.  
  927. Sub ForeignNameX()
  928.  
  929.    Dim dbsNorthwind As Database
  930.    Dim relLoop As Relation
  931.  
  932.    Set dbsNorthwind = CurrentDb() 'OpenDatabase("Northwind.mdb")
  933.  
  934.    Debug.Print "Relation"
  935.    Debug.Print "        Table - Field"
  936.    Debug.Print "  Primary (One) ";
  937.    Debug.Print ".Table - .Fields(0).Name"
  938.    Debug.Print "  Foreign (Many)  ";
  939.    Debug.Print ".ForeignTable - .Fields(0).ForeignName"
  940.  
  941.    ' Enumerate the Relations collection of the Northwind
  942.    ' database to report on the property values of
  943.    ' the Relation objects and their Field objects.
  944.    For Each relLoop In dbsNorthwind.Relations
  945.       With relLoop
  946.          Debug.Print
  947.          Debug.Print .Name & " Relation"
  948.          Debug.Print "        Table - Field"
  949.          Debug.Print "  Primary (One) ";
  950.          Debug.Print .Table & " - " & .Fields(0).Name
  951.          Debug.Print "  Foreign (Many)  ";
  952.          Debug.Print .ForeignTable & " - " & _
  953.             .Fields(0).ForeignName
  954.       End With
  955.    Next relLoop
  956.  
  957.    dbsNorthwind.Close
  958.  
  959. End Sub
  960.  
  961. 'Purpose:   Show additional information beside each field in the Print Relationships report.
  962. 'Author:    Allen Browne. allen@allenbrowne.com. February 2006.
  963. 'Usage:     Set the On Click property of a command button to:
  964. '               =RelReport()
  965. 'Method     The Relationships report uses a list box for each table.
  966. '           We open the report, switch to design view, and change the RowSource of each list box,
  967. '           to give more detailed information on each field, by adding the codes below to each field.
  968.  
  969. ' These codes are added to the field names in the Relationships report:
  970.  
  971. ' Field Types:
  972. ' ===========
  973. '  A    AutoNumber field (size Long Integer)
  974. '  B    Byte (Number)
  975. '  C    Currency
  976. '  Dbl  Double (Number)
  977. '  Dec  Decimal (Number)
  978. '  Dt   Date/Time
  979. '  Guid Replication ID (Globally Unique IDentifier)
  980. '  Hyp  Hyperlink
  981. '  Int  Integer (Number)
  982. '  L    Long Integer (Number)
  983. '  M    Memo field
  984. '  Ole  OLE Object
  985. '  Sng  Single (Number)
  986. '  T    Text, with number of characters (size)
  987. '  Yn   Yes/No
  988. '  ?    Unknown field type
  989.  
  990. ' Indexes:
  991. ' =======
  992. '  P    Primary Key
  993. '  U    Unique Index ('No Duplicates')
  994. '  I    Indexed ('Duplicates Ok')
  995. ' Note: Lower case p, u, or i indicates a secondary field in a multi-field index.
  996.  
  997. ' Properties:
  998. ' ==========
  999. '  D    Default Value set.
  1000. '  R    Required property is Yes
  1001. '  V    Validation Rule set.
  1002. '  Z    Allow Zero-Length is Yes (Text, Memo and Hyperlink only.)
  1003.  
  1004. Public Function RelReport(Optional bSetMarginsAndOrientation As Boolean = True) As Long
  1005. 'On Error GoTo Err_Handler
  1006.     'Purpose:   Main routine. Opens the relationships report with extended field information.
  1007.     'Author:    Allen Browne. allen@allenbrowne.com. January 2006.
  1008.     'Argument:  bSetMarginsAndOrientation = False to NOT set margins and landscape.
  1009.     'Return:    Number of tables adjusted on the Relationships report.
  1010.     'Notes:     1. Only tables shown in the Relationships diagram are processed.
  1011.     '           2. The table's record count is shown in brackets after the last field.
  1012.     '           3. Aliased tables (typically duplicate copies) are not processed.
  1013.     '           4. System fields (used for replication) are suppressed.
  1014.     '           5. Setting margins and orientation operates only in Access 2002 and later.
  1015.     Dim DB As DAO.Database      'This database.
  1016.     Dim tdf As DAO.TableDef     'Each table referenced in the Relationships window.
  1017.     Dim ctl As Control          'Each control on the report.
  1018.     Dim lngKt As Long           'Count of tables processed.
  1019.     Dim strReportName As String 'Name of the relationships report
  1020.     Dim strMsg As String        'MsgBox message.
  1021.  
  1022.     'Initialize: Open the Relationships report in design view.
  1023.     Set DB = CurrentDb()
  1024.     'strReportName = OpenRelReport(strMsg)
  1025.     'If strReportName <> vbNullString Then
  1026.  
  1027.         'Loop through the controls on the report.
  1028.         'For Each ctl In Reports(strReportName).Controls
  1029.             'If ctl.ControlType = acListBox Then
  1030.                 'Set the TableDef based on the Caption of the list box's attached label.
  1031.                 If TdfSetOk(DB, tdf, ctl, strMsg) Then
  1032.                     'Change the RowSource to the extended information
  1033.                     ctl.RowSource = DescribeFields(tdf)
  1034.                     lngKt = lngKt + 1&  'Count the tables processed successfully.
  1035.                 End If
  1036.             'End If
  1037.         'Next
  1038.  
  1039.         'Results
  1040. '        If lngKt = 0& Then
  1041. '            'Notify the user if the report did not contain the expected controls.
  1042. '            strMsg = strMsg & "Diagram of tables not found on report " & strReportName & vbCrLf
  1043. '        Else
  1044. '            'Preview the report.
  1045. '            Reports(strReportName).Section(acFooter).Height = 0&
  1046. '            DoCmd.OpenReport strReportName, acViewPreview
  1047. '            'Reduce margins and switch to landscape (Access 2002 and later only.)
  1048. '            If bSetMarginsAndOrientation Then
  1049. '                Call SetMarginsAndOrientation(Reports(strReportName))
  1050. '            End If
  1051. '        End If
  1052.     'End If
  1053.  
  1054. Exit_Handler:
  1055.     'Show any message.
  1056. '    If strMsg <> vbNullString Then
  1057. '        MsgBox strMsg, vbInformation, "Relationships Report (adjusted)"
  1058. '    End If
  1059.     'Clean up
  1060.     'Set ctl = Nothing
  1061.     Set DB = Nothing
  1062.     'Return the number of tables processed.
  1063.     RelReport = lngKt
  1064.     Exit Function
  1065.  
  1066. Err_Handler:
  1067.     strMsg = strMsg & "RelReport: Error " & Err.Number & ": " & Err.Description & vbCrLf
  1068.     Resume Exit_Handler
  1069. End Function
  1070.  
  1071. Public Function OpenRelReport(strErrMsg As String) As String
  1072. On Error GoTo Err_Handler
  1073.     'Purpose:   Open the Relationships report.
  1074.     'Return:    Name of the report. Zero-length string on failure.
  1075.     'Argument:  String to append any error message to.
  1076.     Dim iAccessVersion As Integer     'Access version.
  1077.  
  1078.     iAccessVersion = Int(Val(SysCmd(acSysCmdAccessVer)))
  1079.     Select Case iAccessVersion
  1080.     Case Is < 9
  1081.         strErrMsg = strErrMsg & "Requires Access 2000 or later." & vbCrLf
  1082.     Case 9
  1083.         RunCommand acCmdRelationships
  1084.         SendKeys "%FR", True  'File | Relationships. RunCommand acCmdPrintRelationships is not in A2000.
  1085.         RunCommand acCmdDesignView
  1086.     Case Is > 9
  1087.         RunCommand acCmdRelationships
  1088.         RunCommand 483        ' acCmdPrintRelationships
  1089.         RunCommand acCmdDesignView
  1090.     End Select
  1091.  
  1092.     'Return the name of the last report opened
  1093.     OpenRelReport = Reports(Reports.Count - 1&).Name
  1094.  
  1095. Exit_Handler:
  1096.     Exit Function
  1097.  
  1098. Err_Handler:
  1099.     Select Case Err.Number
  1100.     Case 2046&  'Relationships window is already open.
  1101.         'A2000 cannot recover, because SendKeys requires focus on the window.
  1102.         If iAccessVersion > 9 Then
  1103.             Resume Next
  1104.         Else
  1105.             strErrMsg = strErrMsg & "Close the relationships window, and try again." & vbCrLf
  1106.             Resume Exit_Handler
  1107.         End If
  1108.     Case 2451&, 2191&  'Report not open, or not open in design view.
  1109.         strErrMsg = strErrMsg & "The Relationships report must be open in design view." & vbCrLf
  1110.         Resume Exit_Handler
  1111.     Case Else
  1112.         strErrMsg = strErrMsg & "Error " & Err.Number & ": " & Err.Description & vbCrLf
  1113.         Resume Exit_Handler
  1114.     End Select
  1115. End Function
  1116.  
  1117. Public Function TdfSetOk(DB As DAO.Database, tdf As DAO.TableDef, ctl As Control, strErrMsg As String) As Boolean
  1118. On Error GoTo Err_Handler
  1119.     'Purpose:   Set the TableDef passed in, using the name in the Caption in the control's attached label.
  1120.     'Return:    True on success. (Fails if the caption is an alias.)
  1121.     'Arguments: db = database variable (must already be set).
  1122.     '           tdf = the TableDef variable to be set.
  1123.     '           ctl = the control that has the name of the table in its attached label.
  1124.     '           strMsg = string to append any error messages to.
  1125.     Dim strTable As String      'The name of the table.
  1126.  
  1127.     strTable = ctl.Controls(0).Caption  'Get the name of the table from the attached label's caption.
  1128.     Set tdf = DB.TableDefs(strTable)    'Fails if the caption is an alias.
  1129.     TdfSetOk = True                     'Return true if it all worked.
  1130.  
  1131. Exit_Handler:
  1132.     Exit Function
  1133.  
  1134. Err_Handler:
  1135.     Select Case Err.Number
  1136.     Case 3265&  'Item not found in collection. (Table name is an alias.)
  1137.         strErrMsg = strErrMsg & "Skipped table " & strTable & vbCrLf
  1138.     Case Else
  1139.         strErrMsg = strErrMsg & "Error " & Err.Number & ": " & Err.Description & vbCrLf
  1140.     End Select
  1141.     Resume Exit_Handler
  1142. End Function
  1143.  
  1144. Public Function DescribeFields(tdf As DAO.TableDef) As String
  1145.     'Purpose:   Loop through the fields of the table passed in, to create a string _
  1146.                     to use as the RowSource of the list box (Value List type).
  1147.     Dim fld As DAO.Field        'Each field of the table.
  1148.     Dim strReturn As String     'String to build up and return.
  1149.     Const strcSep = ";"         'Separator between items in the list box.
  1150.  
  1151.     For Each fld In tdf.Fields
  1152.         'Skip replication info fields.
  1153.         If (fld.Attributes And dbSystemField) = 0& Then
  1154.             'strReturn = strReturn & """" & fld.Name & "   "
  1155.             strReturn = strReturn & "\le#\FS[8]\FC[0]" & fld.Name & " "
  1156.             strReturn = strReturn & "\FS[6]\FC[255] - "
  1157.  
  1158. '\FS[float] // font size
  1159. '• \FC[ULONG] // font color
  1160.  
  1161.             'Describe the field type and size.
  1162.             Select Case CLng(fld.type)
  1163.                 Case dbText
  1164.                     strReturn = strReturn & "T" & fld.Size
  1165.                     If fld.AllowZeroLength Then
  1166.                         strReturn = strReturn & "Z"
  1167.                     End If
  1168.                 Case dbMemo
  1169.                     If (fld.Attributes And dbHyperlinkField) <> 0& Then
  1170.                         strReturn = strReturn & "Hyp" 'Hyperlink
  1171.                     Else
  1172.                         strReturn = strReturn & "M"
  1173.                     End If
  1174.                     If fld.AllowZeroLength Then
  1175.                         strReturn = strReturn & "Z"
  1176.                     End If
  1177.                 Case dbLong
  1178.                     If (fld.Attributes And dbAutoIncrField) <> 0& Then
  1179.                         strReturn = strReturn & "A"   'AutoNumber.
  1180.                     Else
  1181.                         strReturn = strReturn & "L"
  1182.                     End If
  1183.                 Case dbInteger
  1184.                     strReturn = strReturn & "Int"
  1185.                 Case dbCurrency
  1186.                     strReturn = strReturn & "C"
  1187.                 Case dbDate
  1188.                     strReturn = strReturn & "Dt"
  1189.                 Case dbDouble
  1190.                     strReturn = strReturn & "Dbl"
  1191.                 Case dbSingle
  1192.                     strReturn = strReturn & "Sng"
  1193.                 Case dbByte
  1194.                     strReturn = strReturn & "B"
  1195.                 Case dbDecimal
  1196.                     strReturn = strReturn & "Dec"
  1197.                 Case dbBoolean
  1198.                     strReturn = strReturn & "Yn"
  1199.                 Case dbLongBinary
  1200.                     strReturn = strReturn & "Ole"
  1201.                 Case dbGUID
  1202.                     strReturn = strReturn & "Guid"
  1203.                 Case Else
  1204.                     strReturn = strReturn & "?"
  1205.             End Select
  1206.  
  1207.             'Assign codes for the field's crucial properties:
  1208.             If fld.Required Then            'Required?
  1209.                 strReturn = strReturn & "R"
  1210.             End If                          'Validation Rule?
  1211.             If fld.ValidationRule <> vbNullString Then
  1212.                 strReturn = strReturn & "V"
  1213.             End If                          'Default Value?
  1214.             If fld.DefaultValue <> vbNullString Then
  1215.                 strReturn = strReturn & "D"
  1216.             End If
  1217.  
  1218.             'Indicate if field is indexed.
  1219.             strReturn = strReturn & DescribeIndexField(tdf, fld.Name) & " " '"""" & strcSep
  1220.         End If
  1221.  
  1222.     strReturn = strReturn & vbCrLf
  1223.     Next
  1224.  
  1225.     DescribeFields = strReturn & "\le#\FS[6]\FC[255]Total Records: " & DCount("*", tdf.Name)
  1226.     'DescribeFields = strReturn & """     (" & DCount("*", tdf.Name) & ")"""
  1227. End Function
  1228.  
  1229. Public Function DescribeIndexField(tdf As DAO.TableDef, strField As String) As String
  1230.     'Purpose:   Indicate if the field is part of a primary key or unique index.
  1231.     'Return:    String containing "P" if primary key, "U" if uniuqe index, "I" if non-unique index.
  1232.     '           Lower case letters if secondary field in index. Can have multiple indexes.
  1233.     'Arguments: tdf = the TableDef the field belongs to.
  1234.     '           strField = name of the field to search the Indexes for.
  1235.     Dim ind As DAO.index        'Each index of this table.
  1236.     Dim fld As DAO.Field        'Each field of the index
  1237.     Dim iCount As Integer
  1238.     Dim strReturn As String     'Return string
  1239.  
  1240.     For Each ind In tdf.Indexes
  1241.         iCount = 0
  1242.         For Each fld In ind.Fields
  1243.             If fld.Name = strField Then
  1244.                 If ind.Primary Then
  1245.                     strReturn = strReturn & IIf(iCount = 0, "P", "p")
  1246.                 ElseIf ind.Unique Then
  1247.                     strReturn = strReturn & IIf(iCount = 0, "U", "u")
  1248.                 Else
  1249.                     strReturn = strReturn & IIf(iCount = 0, "I", "i")
  1250.                 End If
  1251.             End If
  1252.             iCount = iCount + 1
  1253.  
  1254.         Next
  1255.     Next
  1256.  
  1257.     DescribeIndexField = strReturn
  1258. End Function
  1259.  
  1260. Public Function SetMarginsAndOrientation(obj As Object) As Boolean
  1261.     'Purpose:   Set half-inch margins, and switch to landscape orientation.
  1262.     'Argument:  the report. (Object used, because Report won't compile in early versions.)
  1263.     'Return:    True if set.
  1264.     'Notes:     1. Applied in Access 2002 and later only.
  1265.     '           2. Setting orientation in design view and then opening in preview does not work reliably.
  1266.     Const lngcMargin = 720&     'Margin setting in twips (0.5")
  1267.  
  1268.     'Access 2000 and earlier do not have the Printer object.
  1269.     If Int(Val(SysCmd(acSysCmdAccessVer))) >= 10 Then
  1270.         With obj.Printer
  1271.             .TopMargin = lngcMargin
  1272.             .BottomMargin = lngcMargin
  1273.             .LeftMargin = lngcMargin
  1274.             .RightMargin = lngcMargin
  1275.             .Orientation = 2            'acPRORLandscape not available in A2000.
  1276.         End With
  1277.  
  1278.         'Return True if set.
  1279.         SetMarginsAndOrientation = True
  1280.     End If
  1281. End Function
  1282.  
  1283. Public Sub GetBlob(rb As RelBlob, rl() As RelWindow, Optional TheUser As String = "", Optional TheMDB As String = "")
  1284. ' Supply params if using External MDB
  1285. ' TheMDB must be include full path info
  1286. Dim a() As Byte
  1287. Dim lTemp As Long
  1288. Dim X As Long
  1289. 'Dim rb As RelBlob
  1290. ' Module Level instead of private
  1291. 'Dim rl() As RelWindow
  1292. Dim rst As DAO.Recordset
  1293. Dim sSQL As String
  1294. Dim sSel As String
  1295. Dim DB As DAO.Database
  1296.  
  1297. ' Read the Relationship window BLOB into our array
  1298. ' Assumes CURRENTUSER is the same user who setup and saved the current Relationship window
  1299. ' layout for the internal tables. For an External MDB we supply the User!
  1300. If Len(TheUser & vbNullString) > 0 Then
  1301.     sSel = TheUser
  1302. Else
  1303.     sSel = CurrentUser
  1304.  End If
  1305.  
  1306. If Len(TheMDB & vbNullString) > 0 Then
  1307.     Set DB = OpenDatabase(TheMDB, False, True)
  1308. Else
  1309.     Set DB = CurrentDb()
  1310.  End If
  1311.  
  1312.  sSQL = "SELECT * FROM MSysObjects WHERE NAME = " & """" & sSel & """"
  1313.  Set rst = DB.OpenRecordset(sSQL, dbOpenDynaset, dbReadOnly)
  1314.  
  1315. ' Get length of BLOB
  1316. 'lTemp = LenB(rst.Fields("LVExtra"))
  1317. lTemp = rst.Fields("LVExtra").FieldSize()
  1318.  
  1319. ReDim a(0 To lTemp)
  1320. ' Copy Blob to our array
  1321. a = rst.Fields("LVExtra").GetChunk(0, lTemp)
  1322. ' Below does not work in A97 so we will use DAO
  1323. 'a = rst.Fields("LVExtra")
  1324. ' Free our RecordSet
  1325. Set rst = Nothing
  1326. DB.Close
  1327. Set DB = Nothing
  1328.  
  1329. ' Fill in our RelBlob header
  1330. CopyMem rb, a(0), Len(rb)
  1331.  
  1332. ' Fill in our TextBox controls
  1333. 'Me.txtAAAs = rb.AAAs
  1334. 'Me.txtBlank = rb.Blank
  1335. 'Me.txtFFFs = rb.FFFs
  1336. 'Me.txtNumWindows = rb.NumWindows
  1337. 'Me.txtPadding = rb.Pad
  1338. 'Me.txtSig = rb.Sig
  1339. 'Me.txtRelWinX1 = rb.RelWinX1
  1340. 'Me.txtRelWinX2 = rb.RelWinX2
  1341. 'Me.txtRelWinY1 = rb.RelWinY1
  1342. 'Me.txtRelWinY2 = rb.RelWinY2
  1343. 'Me.txtClientRectY = rb.ClientRectY
  1344. 'Me.txtClientRectX = rb.ClientRectX
  1345.  
  1346. ' First 68 Bytes are the Header
  1347. ' This is followed by (NumWindows + 1) * 284 bytes per record
  1348. ' Last record seems to be padding
  1349. ' Let's create an array of our RelWin structures
  1350. ReDim rl(0 To rb.NumWindows - 1)
  1351. ' Fill in our array of structures
  1352. For X = 0 To rb.NumWindows - 1
  1353.     CopyMem rl(X), a((X * 284) + 68), 284 '(rb.NumWindows + 1) * 128
  1354. Next X
  1355.  
  1356. End Sub
  1357.  
  1358. Public Function RelationsToPDF(ctl As Access.Control) As Boolean
  1359. ' The Font characteristics of the control passed to this function
  1360. ' are used for the created PDF document.
  1361.  
  1362. Dim rlBlob() As RelWindow
  1363. ' Copy of RelWindow but with minimal info and no fixed length strings
  1364. Dim rl() As RelWindowMin
  1365. Dim rlTemp() As RelWindowMin
  1366.  
  1367. ' The RelationShip window BLOB from the System table
  1368. Dim rb As RelBlob
  1369.  
  1370. Dim DB As DAO.Database      'This database.
  1371. Dim tdf As DAO.TableDef     'Each table referenced in the Relationships window.
  1372. Dim tdfForeign As DAO.TableDef
  1373.  
  1374. Dim SRelTableName As String
  1375. Dim SRelFieldName As String
  1376. Dim sCodes As String
  1377.  
  1378. Dim s As String, sTable As String, sForeign As String
  1379. Dim blRet As Boolean
  1380. Dim lRet As Long
  1381. Dim lTemp As Long
  1382.  
  1383. ' Current Screen Resolution
  1384. Dim Xdpi As Double
  1385. Dim Ydpi As Double
  1386. Dim lngIC As Long
  1387. Dim ConvX As Double
  1388. Dim ConvY As Double
  1389.  
  1390. Dim X1 As Long, X2 As Long, Y1 As Long, Y2 As Long
  1391. Dim X2Max As Long, Y2Max As Long
  1392. Dim X1Prev As Long, Y1Prev As Long
  1393. X2Max = 0
  1394. Y2Max = 0
  1395. Dim ctr As Long
  1396.  
  1397. ' Current Column window width
  1398. Dim Width As Long
  1399.  
  1400. ' Vars to create Font and Measure Text Width and Height
  1401. ' Structure for DrawText calc
  1402.  Dim sRect As RECT
  1403.  
  1404.  ' Reports Device Context
  1405.  Dim hDC As Long
  1406.  
  1407.  Dim newfont As Long
  1408.  ' Handle to our Font Object we created.
  1409.  ' We must destroy it before exiting main function
  1410.  
  1411.  Dim oldfont As Long
  1412.  ' Device COntext's Font we must Select back into the DC
  1413.  ' before we exit this function.
  1414.  
  1415.   ' Logfont struct
  1416.  Dim myfont As LOGFONT
  1417.  
  1418.  ' TextMetric struct
  1419.  Dim tm As TEXTMETRIC
  1420.  
  1421.  ' LineSpacing Amount
  1422.  Dim lngLineSpacing As Long
  1423.  
  1424.  ' Ttemp var
  1425.  Dim numLines As Long
  1426.  
  1427.  ' Temp string var for current printer name
  1428.  Dim strName As String
  1429.  
  1430.  ' Temp vars
  1431.  Dim sngTemp1 As Single
  1432.  Dim sngTemp2 As Single
  1433.  
  1434. Dim sText As String
  1435. ' RelationShip OrdinalPosition Primary table->Field
  1436. Dim ReOPp As Integer
  1437. ' RelationShip OrdinalPosition Foreign table->Field
  1438. Dim ReOPf As Integer
  1439. Dim fld As DAO.Field
  1440.  
  1441. ' inner loop counter
  1442. Dim i As Integer
  1443.  
  1444. Dim rel As Relation
  1445.  
  1446.  
  1447. ' Let's see if the DynaPDF.DLL is available.
  1448. blRet = LoadLib()
  1449. If blRet = False Then
  1450.     ' Cannot find DynaPDF.dll or StrStorage.dll file
  1451.     Exit Function
  1452. End If
  1453.  
  1454. On Error GoTo ERR_RelationsToPDF
  1455.  
  1456.  
  1457. 'Initialize: Open the Relationships report in design view.
  1458.     Set DB = CurrentDb()
  1459.  
  1460. sCodes = ""
  1461. ' Field Types:
  1462. ' ===========
  1463. '  A    AutoNumber field (size Long Integer)
  1464. '  B    Byte (Number)
  1465. '  C    Currency
  1466. '  Dbl  Double (Number)
  1467. '  Dec  Decimal (Number)
  1468. '  Dt   Date/Time
  1469. '  Guid Replication ID (Globally Unique IDentifier)
  1470. '  Hyp  Hyperlink
  1471. '  Int  Integer (Number)
  1472. '  L    Long Integer (Number)
  1473. '  M    Memo field
  1474. '  Ole  OLE Object
  1475. '  Sng  Single (Number)
  1476. '  T    Text, with number of characters (size)
  1477. '  Yn   Yes/No
  1478. '  ?    Unknown field type
  1479.  
  1480. ' Indexes:
  1481. ' =======
  1482. '  P    Primary Key
  1483. '  U    Unique Index ('No Duplicates')
  1484. '  I    Indexed ('Duplicates Ok')
  1485. ' Note: Lower case p, u, or i indicates a secondary field in a multi-field index.
  1486.  
  1487. ' Properties:
  1488. ' ==========
  1489. '  D    Default Value set.
  1490. '  R    Required property is Yes
  1491. '  V    Validation Rule set.
  1492. '  Z    Allow Zero-Length is Yes (Text, Memo and Hyperlink only.)
  1493.  
  1494. ' Get current Screen DPI
  1495. lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
  1496. 'If the call to CreateIC didn't fail, then get the Screen X resolution.
  1497. If lngIC <> 0 Then
  1498.     Xdpi = apiGetDeviceCaps(lngIC, LOGPIXELSX)
  1499.     Ydpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
  1500.     'Release the information context.
  1501.     apiDeleteDC (lngIC)
  1502. Else
  1503.     ' Something has gone wrong. Assume an average value.
  1504.     Xdpi = 120
  1505.     Ydpi = 120
  1506. End If
  1507.  
  1508. ' Create a temp Device Context
  1509. ' Create our Font and select into the DC
  1510. ' Get handle to screen Device Context
  1511. hDC = apiGetDC(0&)
  1512.  
  1513. With ctl
  1514.      myfont.lfClipPrecision = CLIP_LH_ANGLES
  1515.      myfont.lfOutPrecision = OUT_TT_ONLY_PRECIS
  1516.      myfont.lfEscapement = 0
  1517.      myfont.lfFaceName = .FontName & Chr$(0)
  1518.      myfont.lfWeight = .FontWeight
  1519.      myfont.lfItalic = .FontItalic
  1520.      myfont.lfUnderline = .FontUnderline
  1521.      'Must be a negative figure for height or system will return
  1522.      'closest match on character cell not glyph
  1523.      myfont.lfHeight = (.FontSize / 72) * -Ydpi
  1524.      ' Create our temp font
  1525.      newfont = apiCreateFontIndirect(myfont)
  1526.  End With
  1527.  
  1528.      If newfont = 0 Then
  1529.          Err.Raise vbObjectError + 256, "fTextWidthOrHeight", "Cannot Create Font"
  1530.      End If
  1531.  
  1532.  ' Select the new font into our DC.
  1533.  oldfont = apiSelectObject(hDC, newfont)
  1534.  
  1535.  ' Get TextMetrics. This is required to determine
  1536.    ' Text height and the amount of extra spacing between lines.
  1537.    lRet = GetTextMetrics(hDC, tm)
  1538.  
  1539.  ' Our DC is now ready for our calls to:
  1540.  ' Calculate our bounding box based on the controls current width
  1541. '   lngRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or DT_TOP Or _
  1542. '   DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or DT_EDITCONTROL Or DT_NOCLIP)
  1543.  
  1544. ' Decode the RelationShip window BLOB
  1545. GetBlob rb, rlBlob
  1546. ' Copy of array of RelWindow structures over to our minimal RelWindow struct
  1547. ' so we can get rid of unused junk and the fixed length Unicode strings.
  1548. ReDim Preserve rl(0 To UBound(rlBlob))
  1549.  
  1550. For ctr = 0 To rb.NumWindows - 1
  1551.     With rl(ctr)
  1552.         ' rb.ScrollBarXoffset + rb.ScrollBarYoffset will always be either:
  1553.         ' 0 - Both Vertical and Horiz ScrollBars are at the Home(0,0) position
  1554.         ' a value signifying the offset of the pertinent ScrollBar to be added
  1555.         ' to the negative X1,Y1,X2,Y2 coordinates.
  1556.         ' We can safely add
  1557.         .RelWinX1 = (rlBlob(ctr).RelWinX1) + rb.ScrollBarXoffset
  1558.         .RelWinX2 = (rlBlob(ctr).RelWinX2) + rb.ScrollBarXoffset
  1559.         .RelWinY1 = (rlBlob(ctr).RelWinY1) + rb.ScrollBarYoffset
  1560.         .RelWinY2 = (rlBlob(ctr).RelWinY2) + rb.ScrollBarYoffset
  1561.  
  1562. '        ' Add a user defined Left Margin
  1563. '        Dim LeftMargin As Long
  1564. '        LeftMargin = 20
  1565. '        .RelWinX1 = .RelWinX1 + LeftMargin
  1566. '        .RelWinX2 = .RelWinX2 + LeftMargin
  1567.  
  1568.         s = StrConv(rlBlob(ctr).WinName, vbFromUnicode)
  1569.         s = Left$(s, InStr(1, s, Chr(0)) - 1)
  1570.         .WinName = s
  1571.     End With
  1572. Next ctr
  1573.  
  1574. ' We need to perform several modifications to the BLOB data:
  1575. '1) Resize the height of each window so that all of the table's fields will be visible.
  1576. '   We will have to calculate a new Y1 position after we increate the height of the window.
  1577. '
  1578. '2) Resize the width of each window so that the Table name and all of the
  1579. '   field names will fit. Use a smaller font if the calculated width is larger
  1580. '   than our desired max width. Remember, I want to use a fixed width for the
  1581. '   columns of our output.
  1582. '3)
  1583. '
  1584. '
  1585. ' The most difficult issue is to move every window to a column. Basically we want
  1586. ' to implement a Snap to Grid effect.
  1587. ' Here is the logic:
  1588. ' Loop through all windows
  1589. ' Find the smallest X1 with the smallest Y1
  1590. ' This becomes our first window
  1591. ' Start looping again, this time finding the smallest X1 with the smallest Y1
  1592. ' that is larger than the previous Y1. This logic will ensure we are always working
  1593. ' down the grid. When we can no longer find any Y1 coords that are larger than previous
  1594. ' Y1 we are done this column of the grid. We then start over from the top again.
  1595. ' The logic is further constrained each time in the X direction for each column of
  1596. ' the grid we are building. X1 must be less than the width of the table at the
  1597. ' very top of the column we are currently working on. In other words, the starting X1
  1598. ' position of the next table window below the first one in this column must have a
  1599. ' starting X1 position less than the X1 + width of the first window in this column.
  1600. ' If there are two smaller windows under a wide window, and the second window's Y1 meets
  1601. ' the criteria of being larger than the first small window, we will move this second
  1602. ' small window directly underneath the first small window. It's the only exception I
  1603. ' can think of at this pointin developing this logic.
  1604.  
  1605. ' Ok, we'll need an array and/or a collection to process implement our logic.
  1606. ' We really only need to store each Table name in final desired column row/order.
  1607.  
  1608. ' At this point we will not modify the original rl() array.
  1609. ' Let's try a Collection for now. The key will be the Table Name. We do not need
  1610. ' to actually store any data as the order of the Key is what is important.
  1611. ' Basically using the Collection as an odered list.
  1612.  
  1613.  
  1614. ' First we find the smallest Y1 with the smallest X1.
  1615. ' This gives us the topmost window in this column
  1616. ' Next we search for the smallest X1 with a Y1 that is >= to the previous Y1.
  1617. ' We'll copy our rl() array over to a temp Collection
  1618. ' so that we can remove entries as we process to
  1619. ' speed up processing.
  1620.  
  1621. ' Final Output order of windows
  1622. Dim cOut As New Collection
  1623. ' Temp working Collection
  1624. Dim cTmp As New Collection
  1625.  
  1626. ' Current Column Counter
  1627. Dim CurCol As Long
  1628. ' Need to use/store the array index instead of a single instance of Rel Window structure as VB
  1629. ' will not accept a structure for the Item param of the Add method of the Collection object.
  1630. 'Dim r As RelWindowMin
  1631. ' Copy to temp Collection
  1632. For ctr = 0 To rb.NumWindows - 1
  1633.     With rl(ctr)
  1634.         cTmp.Add Item:=ctr, Key:=.WinName
  1635.     End With
  1636. Next ctr
  1637.  
  1638. ' Non existent seed values
  1639. X1Prev = 100000
  1640. Y1Prev = 100000
  1641. ' Find Top and left most window. Smallet X1 and Y1
  1642. Dim obj As Variant
  1643. Dim sNamePrev As String
  1644. ' Need to flag when we are at the bottom of a column
  1645. 'so we can reset seed values.
  1646. ' No I think we can just keep finding the left most and top most window
  1647. ' continually until all windows are processed/found.
  1648.  
  1649.  
  1650. ' SNAP TO GRID
  1651. 'for i =8 to 80 step 8
  1652. ' ****************************************************************************************
  1653. Dim SpacingInterval As Long
  1654.  
  1655. ' Add a user defined Left Margin
  1656.         Dim LeftMargin As Long
  1657.         LeftMargin = 20
  1658.  
  1659.  
  1660. ' Force window to multiple of SpacingInterval value.
  1661. ' if less than halfway then go backwards to previous multiple.
  1662. ' if more than or equal to halfway then go ahead to next multiple.
  1663. SpacingInterval = 200 ' was 200 sat march 11 at 5:57pm200
  1664. 'For i = 100 To 200 Step 100
  1665. '    SpacingInterval = i '* 25
  1666.     For ctr = 0 To rb.NumWindows - 1
  1667.         ' Move to multiple of SpacingInterval
  1668.         ' Move to 0 if X1 is less than SpacingInterval
  1669.         If rl(ctr).RelWinX1 <= SpacingInterval Then
  1670.             rl(ctr).RelWinX1 = LeftMargin  '0
  1671.         Else
  1672.             ' Calculate which column X1 is in.
  1673.             lRet = Int(rl(ctr).RelWinX1 / SpacingInterval)
  1674.             lTemp = rl(ctr).RelWinX1 - (SpacingInterval * lRet)
  1675.             ' Less than half way to next multiple of SpacingInterval
  1676.             If lTemp <= SpacingInterval / 2 Then
  1677.                 ' Move back
  1678.                 lTemp = -lTemp 'SpacingInterval - lTemp
  1679.             Else
  1680.                 ' More than halfway to next multiple of SpacingInterval
  1681.                 ' Move forward
  1682.                 lTemp = SpacingInterval - lTemp
  1683.             End If
  1684.             ' Update coords
  1685.             rl(ctr).RelWinX1 = rl(ctr).RelWinX1 + lTemp
  1686.             rl(ctr).RelWinX2 = rl(ctr).RelWinX1 + lTemp
  1687.             rl(ctr).Column = Int(rl(ctr).RelWinX1 / SpacingInterval)
  1688.         End If
  1689.     Next ctr
  1690. 'Next i
  1691.  
  1692. ' ****************
  1693. ' March 11  9:15pm commented out below.
  1694. ' Its' redundand and alreay done just above.
  1695.  
  1696. '' Increase space between SpaceInterval columns
  1697. 'For ctr = 0 To rb.NumWindows - 1
  1698. '    ' Add 300 to each SpacingInterval
  1699. '    ' Determine Column #
  1700. '    If rl(ctr).RelWinX1 < SpacingInterval Then
  1701. '        ' Column = 0
  1702. '        lRet = 0
  1703. '    Else
  1704. '        lRet = Int(rl(ctr).RelWinX1 / SpacingInterval)
  1705. '
  1706. '    End If
  1707. '
  1708. '    ' Update Column member
  1709. '    rl(ctr).Column = lRet
  1710. '    ' Update coords - add min 20 pixels between windows
  1711. '    ' ****************************************
  1712. '    'comment out below March 11-2006
  1713. '    '***********************************************************************
  1714. ''    lTemp = rl(ctr).RelWinX2 - rl(ctr).RelWinX1
  1715. ''    rl(ctr).RelWinX1 = rl(ctr).RelWinX1 + (lRet * 20) 'SpacingInterval) '100) 'lTemp
  1716. ''    rl(ctr).RelWinX2 = rl(ctr).RelWinX1 + lTemp '(lRet * 400)
  1717. ''
  1718. 'Next ctr
  1719.  
  1720.  
  1721. ' Mon - March 6  10:10pm
  1722. ' commented out
  1723.  
  1724. For ctr = 0 To rb.NumWindows - 1
  1725.  
  1726.     For Each obj In cTmp
  1727.  
  1728.  
  1729.         If rl(obj).RelWinX1 = X1Prev Then
  1730.         ' Still in same column
  1731.             If rl(obj).RelWinY1 < Y1Prev Then
  1732.                 Y1Prev = rl(obj).RelWinY1
  1733.                 X1Prev = rl(obj).RelWinX1
  1734.                 sNamePrev = rl(obj).WinName
  1735.                 lRet = obj
  1736.             End If
  1737.  
  1738.         Else
  1739.             If rl(obj).RelWinX1 < X1Prev Then
  1740.  
  1741.             'If rl(obj).RelWinY1 = Y1Prev Then
  1742.                 Y1Prev = rl(obj).RelWinY1
  1743.                 X1Prev = rl(obj).RelWinX1
  1744.                 sNamePrev = rl(obj).WinName
  1745.                 lRet = obj
  1746.  
  1747.             'ElseIf rl(obj).RelWinY1 <= Y1Prev Then
  1748.             End If
  1749.         End If
  1750.     Next obj
  1751.  
  1752.     ' Error checking. Processed all windows
  1753.     If Len(sNamePrev & vbNullString) = 0 Then Exit For
  1754.     ' Update Column member
  1755.  
  1756.     ' Save off this window in our ordered list
  1757.     cOut.Add Item:=lRet, Key:=sNamePrev
  1758.     ' Remove this item from the temp work collection
  1759.     cTmp.Remove sNamePrev
  1760.     ' Reset to non existent seed values
  1761.     X1Prev = 100000
  1762.     Y1Prev = 100000
  1763.     sNamePrev = 0
  1764.  
  1765. Next ctr
  1766.  
  1767. ' When we get to here all windows should have been processed
  1768. ' and our temp work collection should have been emptied.
  1769.  
  1770. ' Mon - March 6  10:10pm
  1771. ' commented out
  1772. 'X1 = 0
  1773. 'Y1 = 0
  1774. '
  1775. ' Make a working copy
  1776. ReDim rlTemp(0 To UBound(rl))
  1777. rlTemp = rl
  1778.  
  1779. ' What we want to do is copy, in order, to the rl() array, via the Collection Item prop
  1780. ' from the rlTemp() array. This will put the windows in order from the
  1781. ' top leftmost to the bottom right most. We need to do this so we can adjust/increase
  1782. ' the height of each Table windows so that all of the fields will be visible.
  1783. ctr = 0
  1784. For Each obj In cOut
  1785.     With rl(ctr)
  1786.         .RelWinX1 = rlTemp(obj).RelWinX1
  1787.         .RelWinY1 = rlTemp(obj).RelWinY1
  1788.         .RelWinX2 = rlTemp(obj).RelWinX2
  1789.         .RelWinY2 = rlTemp(obj).RelWinY2
  1790.         .WinName = rlTemp(obj).WinName
  1791.         .Column = rlTemp(obj).Column
  1792.         ctr = ctr + 1
  1793.     End With
  1794. Next
  1795.  
  1796. Dim MaxDocCharWidth As Long
  1797. Dim MaxDocCharHeight As Long
  1798. ' Width of max documentation characters
  1799. ' Since we are using a 10 point font to calc width but really
  1800. ' outputting 8 point with a 10 point leading then we do not
  1801. ' need any extra char spacing.
  1802.  sText = "XXXXg"
  1803. With sRect
  1804.     .Left = 0
  1805.     .Top = 0
  1806.     .Bottom = 0
  1807.     ' Single line TextWidth
  1808.     .Right = 32000
  1809. End With
  1810.  
  1811.    lRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or DT_TOP Or _
  1812.             DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or DT_EDITCONTROL Or DT_NOCLIP)
  1813.  
  1814.     MaxDocCharWidth = sRect.Right
  1815.     ' Allow for 14 pt header and 10 point leading
  1816.     MaxDocCharHeight = sRect.Bottom ' * 2
  1817.  
  1818.  
  1819.  
  1820. ' Since the DyanPDF library will automatically wrap text to the next line
  1821. ' we have to make sure that the Table name, the field names and the extra
  1822. ' field documenting characters fit one single lines. Otherwise our logic
  1823. ' to calculate the beginning and ending points of the Join lines will not be accurate.
  1824. ' There is an issue of overlap though in the X dimension when I increase the width
  1825. ' of the table window. This is easy to solve in the Y dimension but tougher in the X direction.
  1826. ' I may have to set a fixed width for all windows to solve this issue.
  1827.  
  1828. ' X2Max holds widest Table or Field name.
  1829. ' Loop through all of the table widths and adjust
  1830.  
  1831. ' Add extra space in width to allow for documenting chars.
  1832.  
  1833. ' Let's increase the Width of each Table window so that all fields are visible.
  1834. ' Perhaps we should modify the rl structure to hold max width required to
  1835. ' ensure the table and field names are visible. No let's use a collection object instead.
  1836. ' No we will modify as we go - no need to store this value.
  1837. X2Max = 0
  1838. Y2Max = 0
  1839. Dim bHeader As Boolean
  1840.  
  1841. For ctr = 0 To rb.NumWindows - 1
  1842.     With rl(ctr)
  1843.         ' Call our function to calc height
  1844.         SRelTableName = .WinName '(.WinName) 'StrConv(.WinName, vbFromUnicode)
  1845.         s = Right$(SRelTableName, 3)
  1846.         lRet = InStr(s, "_")
  1847.         If lRet = 1 Or lRet = 2 Then
  1848.             SRelTableName = Mid$(SRelTableName, 1, Len(SRelTableName) - (4 - lRet))
  1849.         End If
  1850.         ' DO NOT need to process this clone/copy - just process main table.
  1851.         ' No we cannot store the original Table window's Max width as it may not have been
  1852.         ' processed at this point.
  1853.         'If lRet = 0 Then
  1854.  
  1855.  
  1856.             Set tdf = DB.TableDefs(SRelTableName) '.WinName)
  1857.             If Not tdf Is Nothing Then
  1858.                 'Calc width of Table name and all Field Names
  1859.                 ' Set width of Table window to max width
  1860.                 sText = tdf.Name
  1861.                 With sRect
  1862.                     .Left = 0
  1863.                     .Top = 0
  1864.                     .Bottom = 0
  1865.                     ' Single line TextWidth
  1866.                     .Right = 32000
  1867.                 End With
  1868.  
  1869.                    lRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or DT_TOP Or _
  1870.                             DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or DT_EDITCONTROL Or DT_NOCLIP)
  1871.  
  1872.                     X2Max = sRect.Right
  1873.                     bHeader = True
  1874.  
  1875.                 For Each fld In tdf.Fields
  1876.                    sText = fld.Name
  1877.                     With sRect
  1878.                         .Left = 0
  1879.                         .Top = 0
  1880.                         .Bottom = 0
  1881.                         ' Single line TextWidth
  1882.                         .Right = 32000
  1883.                     End With
  1884.  
  1885.                    lRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or DT_TOP Or _
  1886.                             DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or DT_EDITCONTROL Or DT_NOCLIP)
  1887.  
  1888.                     If sRect.Right > X2Max Then
  1889.                     X2Max = sRect.Right
  1890.                     bHeader = False
  1891.                     End If
  1892.                 Next
  1893.  
  1894.                 ' ***********************************************************
  1895.                 ' Make this a user optional param
  1896.                 ' Resize to width ALL WINDOWS
  1897.                 ' Get current width of this window. If it is less than X2Max then adjust.
  1898.                 'If .RelWinX2 - .RelWinX1 < X2Max + MaxDocCharWidth Then
  1899.                 ' May 11/2008
  1900.                 ' If Table window width was sized to fit field name + doc chars then
  1901.                 ' somehow it was not increased enough in width
  1902.                 ' Short term solution - set all windows to my calculated width
  1903.                 ' but COME BACK and figure out why!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1904.  
  1905.                  ' May 16/2008
  1906.             ' Add logic to calc sFields width and use this calculated value
  1907.             ' to determine actual table max width. Remember to take the Table name
  1908.             ' into consideration in calculating max width
  1909.                     'If bHeader = True Then
  1910.                      .RelWinX2 = .RelWinX1 + X2Max + MaxDocCharWidth ' + 16
  1911.                     'Else
  1912.                      '   .RelWinX2 = .RelWinX1 + X2Max + MaxDocCharWidth
  1913.                     'End If
  1914.                 Set fld = Nothing
  1915.                 X2Max = 0
  1916.  
  1917.             End If
  1918.         'End If
  1919.  
  1920.     End With
  1921. Next ctr
  1922. Set tdf = Nothing
  1923.  
  1924.  
  1925.  
  1926.  
  1927.  
  1928.  
  1929.  
  1930.  
  1931. ' *****
  1932. ' Adjust Height of all Relationship Table windows.
  1933. ' *****
  1934.  
  1935. ' Let's increase the Width of each Table window so that all fields are visible.
  1936. ' Perhaps we should modify the rl structure to hold max width required to
  1937. ' ensure the table and field names are visible. No let's use a collection object instead.
  1938. ' No we will modify as we go - no need to store this value.
  1939. X2Max = 0
  1940. Y2Max = 0
  1941. For ctr = 0 To rb.NumWindows - 1
  1942.     With rl(ctr)
  1943.         ' Call our function to calc height
  1944.         SRelTableName = .WinName '(.WinName) 'StrConv(.WinName, vbFromUnicode)
  1945.         s = Right$(SRelTableName, 3)
  1946.         lRet = InStr(s, "_")
  1947.         If lRet = 1 Or lRet = 2 Then
  1948.             SRelTableName = Mid$(SRelTableName, 1, Len(SRelTableName) - (4 - lRet))
  1949.         End If
  1950.         ' DO NOT need to process this clone/copy - just process main table.
  1951.         ' No we cannot store the original Table window's Max width as it may not have been
  1952.         ' processed at this point.
  1953.         'If lRet = 0 Then
  1954.  
  1955.         ' Build our string starting with Relationship Table window name
  1956.         sText = SRelTableName & vbCrLf
  1957.  
  1958.             Set tdf = DB.TableDefs(SRelTableName) '.WinName)
  1959.             If Not tdf Is Nothing Then
  1960.                 ' Add individual Field names
  1961.  
  1962.                 For Each fld In tdf.Fields
  1963.                    sText = sText & fld.Name & vbCrLf
  1964.                 Next
  1965.  
  1966.  
  1967.                     With sRect
  1968.                         .Left = 0
  1969.                         .Top = 0
  1970.                         .Bottom = 0
  1971.                         ' Single line TextWidth
  1972.                         .Right = 30000 'rl(ctr).RelWinX2 - rl(ctr).RelWinX1
  1973.                     End With
  1974.  
  1975.                    lRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or DT_TOP Or _
  1976.                             DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or DT_EDITCONTROL Or DT_NOCLIP)
  1977.                 Y2Max = sRect.Bottom
  1978.  
  1979.                 ' Get current height of this window. If it is less than calc Height then adjust.
  1980.                 ' We also need to leave room for an extra row to allow for the
  1981.                 ' Total Recs: line we output
  1982.                 ' May 11/2008 BUG Fix
  1983.                 ' If Table window was sized to display all of its fields then
  1984.                 ' somehow it was being increased too much in height
  1985.                 ' Short term solution - set all windows to my calculated height
  1986.                 ' but COME BACK and figufre out why!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1987.                 'If .RelWinY2 - .RelWinY1 < Y2Max + MaxDocCharHeight Then
  1988.                     .RelWinY2 = .RelWinY1 + Y2Max + MaxDocCharHeight
  1989.                 'End If
  1990.                 Set fld = Nothing
  1991.  
  1992.             End If
  1993.         'End If
  1994.     ' ***
  1995.     '***********************************************
  1996.     ' March 11/2006
  1997.     ' Add code here to set each window to the start of the column.
  1998.     ' Allow user to specify MinColumnSpacing
  1999.     Dim MinColumnSpacing As Long
  2000.  
  2001.     MinColumnSpacing = 40
  2002.     ' SpacingInterval contains relative offset
  2003.  
  2004.  
  2005.  
  2006.  
  2007.     End With
  2008. Next ctr
  2009. Set tdf = Nothing
  2010. Set fld = Nothing
  2011.  
  2012.  
  2013.  
  2014.  
  2015.  
  2016.  
  2017.  
  2018.  
  2019.  
  2020. ' March 6 -2006 10:18pm
  2021. ' COMMENTED out below
  2022.  
  2023.  
  2024. ' *****
  2025. ' Adjust Starting X1 ANd Y1 of all Relationship Table windows.
  2026. ' *****
  2027.  
  2028. ' Let's increase the X1 starting X position of each Table window in order to
  2029. ' increase the spacing between each table. We do this because overlapping conditions
  2030. ' are created when we previously increased the width of each Table window.
  2031. ' To keep this simple, we allow the user to specify a fixed amount for the
  2032. ' spacing value.
  2033. ' Since our array of Rel() structures is ordered from top leftmost to
  2034. ' bottom right most we can basically process the windows in a column by column order.
  2035. '
  2036. ' Because the spacing has to be cumulative per increasing column position, we multiply
  2037. ' the user's desired spacing value by the current column count(zero indexed).
  2038.  
  2039. ' Let's increase the Y1 starting Y position of each Table window in order to
  2040. ' ensure that Table Windows do not overlap. We do this because overlapping conditions
  2041. ' are created when we previously increased the Height of each Table window in order to
  2042. ' ensure that all fields in the table window are visible.
  2043.  
  2044.  
  2045. Dim ctrCol As Long
  2046. 'Dim Y1Prev As Long,
  2047. Dim Y2Prev As Long
  2048. Dim Y2PrevOrig As Long, Y1PrevOrig As Long
  2049. Dim VerticalWindowSpacing As Long
  2050.  
  2051. VerticalWindowSpacing = 14
  2052. Y1Prev = 0
  2053. Y2Prev = 0
  2054. X2Max = 0
  2055. Y2Max = 0
  2056. ctrCol = 0
  2057.  
  2058. Y2PrevOrig = 0
  2059. Y1PrevOrig = 99999999
  2060.  
  2061.  
  2062. For ctr = 0 To rb.NumWindows - 1
  2063.     With rl(ctr)
  2064.         ' Modify Y1 first
  2065.         ' First window in the array is the topmost - leftmost window
  2066.         ' Determine if we are still in the current column.
  2067.         ' If the Y1 of this window is Greater than the Y1 of the
  2068.         ' previous window then we are still in the same column.
  2069.         ' Do need to code exception to handle when this current window
  2070.         ' is in the next column because even though the this Y1 is greater
  2071.         ' than previous Y1, X1 actually places this window in the next column.(I think):-)
  2072.         If .RelWinY1 > Y1PrevOrig Then
  2073.             ' We're still in the same column
  2074.             ' Store Y1
  2075.             Y1PrevOrig = .RelWinY1
  2076.             ' Are we overlapping the previous window in this column.
  2077.             If (.RelWinY1 < Y2Prev + VerticalWindowSpacing) And Y2Prev <> 0 Then
  2078.                 ' Reposition to avoid overlap - calc resize first
  2079.                 .RelWinY2 = (.RelWinY2 - .RelWinY1) + Y2Prev + VerticalWindowSpacing
  2080.                 .RelWinY1 = Y2Prev + VerticalWindowSpacing
  2081.  
  2082. '                Y2Prev = .RelWinY2
  2083. '                Y1Prev = .RelWinY1
  2084.  
  2085.             'Else
  2086.  
  2087.             End If
  2088.             Y2Prev = .RelWinY2
  2089.                 Y1Prev = .RelWinY1
  2090.  
  2091.         Else
  2092.             ' We're in the next column. Do not resize as it is the top most
  2093.             ' window in this column. Reset seeds to non existent values.
  2094.             ' Next Column
  2095.             ctrCol = ctrCol + 1
  2096.             Y2Prev = .RelWinY2
  2097.                 Y1Prev = .RelWinY1
  2098.                 Y1PrevOrig = .RelWinY1 '0
  2099.             ' Since we are at top of column no need to reposition
  2100.  
  2101.         End If
  2102.  
  2103.     End With
  2104. Next ctr
  2105.  
  2106.  
  2107.  
  2108.  
  2109. ' Set absolute position for start of each column.
  2110. ' Find Max Width of all windows in each column to calc ColumnWidth
  2111. ' Storage for column Widths
  2112. Dim aColWidths() As Long
  2113.  
  2114. Dim lNumColumns As Long
  2115.  
  2116. ' Get Total number of columns
  2117. For ctr = 0 To rb.NumWindows - 1
  2118.     With rl(ctr)
  2119.         If lNumColumns < .Column Then lNumColumns = .Column
  2120.     End With
  2121. Next ctr
  2122.  
  2123.  
  2124. ReDim aColWidths(0 To lNumColumns)
  2125. Dim Gutter As Long
  2126. Gutter = 20
  2127.  
  2128. ' Find largest window width in each column and
  2129. ' store this value in our column width array.
  2130. For ctr = 0 To rb.NumWindows - 1
  2131.     With rl(ctr)
  2132.         If (.RelWinX2 - .RelWinX1) > aColWidths(.Column) Then
  2133.             aColWidths(.Column) = (.RelWinX2 - .RelWinX1)
  2134.         End If
  2135.     End With
  2136. Next ctr
  2137.  
  2138.  
  2139. ' Set X1 for every table window to the calc start of the column.
  2140. ' *****************************
  2141. ' Here we can set the Left Margin
  2142. For ctr = 0 To rb.NumWindows - 1
  2143.     With rl(ctr)
  2144.         ' Column starting position =
  2145.         ' column widths for all previous columns plus
  2146.         ' column spacing value
  2147.         lTemp = 0
  2148.         For i = 0 To .Column - 1
  2149.             lTemp = lTemp + aColWidths(i)
  2150.             lTemp = lTemp + Gutter
  2151.         Next i
  2152.             .RelWinX2 = (.RelWinX2 - .RelWinX1) + lTemp
  2153.             .RelWinX1 = IIf(lTemp = 0, LeftMargin, lTemp)
  2154.  
  2155.     End With
  2156. Next ctr
  2157.  
  2158.  
  2159.  
  2160.  
  2161.  
  2162.  
  2163. ' Loop through all Relationship Table windows to get
  2164. ' the largest X2 and Y2 coordinates.
  2165. ' Modify the starting Y1 coordinate for all Table Windows
  2166. ' to allow for 1 inch Header section.
  2167. ' Finally convert Window coords to 72 PPI used by the DynaPDF library
  2168. '
  2169.  
  2170. X2Max = 0
  2171. Y2Max = 0
  2172. For ctr = 0 To rb.NumWindows - 1
  2173.     With rl(ctr)
  2174.         .RelWinX1 = (.RelWinX1 / Xdpi) * 72
  2175.         .RelWinX2 = ((.RelWinX2 / Xdpi) * 72) ' + 16
  2176.         .RelWinY1 = ((.RelWinY1 / Ydpi) * 72) '+ 16 ' Space for header section
  2177.         .RelWinY2 = ((.RelWinY2 / Ydpi) * 72) '+ 6 ' Space for header section
  2178.     End With
  2179.  
  2180.     X2 = rl(ctr).RelWinX2
  2181.     Y2 = rl(ctr).RelWinY2
  2182.     If X2Max < X2 Then X2Max = X2
  2183.     If Y2Max < Y2 Then Y2Max = Y2
  2184. Next ctr
  2185.  
  2186. ctr = 0
  2187.  
  2188. ' 1) We will have to widen each window to accomodate Allen Browne's
  2189. ' documentation character symbols.
  2190. '
  2191. ' 2) To make it simpler to create the windows in the PDF document
  2192. ' I want to make each window the same width.
  2193.  
  2194. ' In the next release I'll add a param to this function to allow
  2195. ' the user to specify the desired width.
  2196.  
  2197. ' So I'll need a function or functions in the StrStorage DLL
  2198.  
  2199. Dim sFields As String
  2200. Dim sPDF As String
  2201.  
  2202. sPDF = "C:\sourcecode\ReportToPDF\Relations.pdf"
  2203. ' Should calc string width of Allen's Documentation Characters
  2204. ' instead of using the fixed value of 16 Points.
  2205. ' We also need to allow space for a Header or Footer
  2206. lRet = BeginPDF(sPDF, X2Max + 32, Y2Max + 32)
  2207.  
  2208.  
  2209.  
  2210. 'GoTo HHH
  2211.  
  2212.  
  2213.  
  2214. ' The first time through we will just gather the necessary info
  2215. ' to allow us to draw the Relationship Join lines.
  2216. ' We will need to store
  2217. ' Table Name(to index into the Relation object)
  2218. ' Table Ypos
  2219. ' Field Name(to index into Relation object)
  2220. ' Field Pos - 1 to num fields
  2221. For ctr = 0 To rb.NumWindows - 1
  2222.     With rl(ctr)
  2223.         On Error Resume Next
  2224.         SRelTableName = .WinName
  2225.         Set tdf = Nothing
  2226.         ' We don't have to remove _1(_x) from end of WinName because the Relation object
  2227.         ' only stores relations under the original table name - Customers not Customers_1.
  2228.         ' We know it is a Clone/Copy of the Table when the Table and ForeightTable props
  2229.         ' are the same. We can then examine the Name prop, specifically the last char
  2230.         ' to tell what instance of the clone/copy we are working with.
  2231.         ' First instance is Customers_1 then Customers_2 etc. But this logic does not
  2232.         ' carry over to the Name prop of the Relation object.
  2233.         ' Customers_1 = CustomersCustomers
  2234.         ' Customers_2 = CustomersCustomers_1
  2235.         'etc
  2236. '        s = Right$(SRelTableName, 3)
  2237. '        lRet = InStr(s, "_")
  2238. '        If lRet = 1 Or lRet = 2 Then SRelTableName = Mid$(SRelTableName, 1, Len(SRelTableName) - (4 - lRet))
  2239. '
  2240.  
  2241.         Set tdf = DB.TableDefs(SRelTableName)
  2242.         If Not tdf Is Nothing Then
  2243.             'Get Field Name + Documenting info
  2244.             'sFields = DescribeFields(tdf)
  2245.             'lngKt = lngKt + 1&  'Count the tables processed successfully.
  2246.             ' See if there are any matching Relation entries.
  2247.             ' If there are then store the required information
  2248.             ' to allow us to draw the Relationship table/field Lines
  2249.             For Each rel In DB.Relations
  2250.                 If rel.Table = .WinName Then ' Then
  2251.  
  2252.                     ' Draw the Line for this Relationship
  2253.                     ' Get the Ordinal Position of the Primary and ForeignTable fields
  2254.                     Set fld = rel.Fields(0)
  2255.  
  2256.                     ReOPp = tdf.Fields(fld.Name).OrdinalPosition
  2257.  
  2258.                     ' Check if ForeignTable prop is a Clone/Copy
  2259.                     lRet = 0
  2260.                     If rel.Table = rel.ForeignTable Then
  2261.                         ' Determine which copy(_x) this one is
  2262.                         If Len(rel.Table) * 2 = Len(rel.Name) Then
  2263.                             s = rel.ForeignTable & "_" & 1
  2264.                             lRet = 1
  2265.                         Else
  2266.                             ' Grab last character of Name prop. This logic will
  2267.                             ' only support to a max of 9 clones/copies
  2268.                             s = Right$(rel.Name, 1)
  2269.                             s = rel.ForeignTable & "_" & Val(s) + 1
  2270.                             lRet = 1
  2271.                         End If
  2272.  
  2273.                     End If
  2274.  
  2275.                     Set tdfForeign = DB.TableDefs(rel.ForeignTable)
  2276.                     ReOPf = tdfForeign.Fields(fld.ForeignName).OrdinalPosition + 1
  2277.  
  2278.                     ' Calc the start and ending X,Y cordinates for the
  2279.                     ' Relationship Line we are going to draw.
  2280.                     X1 = .RelWinX1 '(.RelWinX1 / Xdpi) * 72
  2281.                     Y1 = .RelWinY1 '(.RelWinY1 / Ydpi) * 72
  2282.                     ' Now we need to add an offset to Y1 to bring us down to
  2283.                     ' the row containing the relationship field. Since the
  2284.                     ' OrdinalPosition index is zero based we don't have to add 1
  2285.                     ' to cover the fact that we output a row first containing
  2286.                     ' the Table name. 10 pts is the row spacing.
  2287.                     Y1 = Y1 + (IIf(ReOPp = 0, 1, ReOPp) * 10)
  2288.                     ' Now we need to find X1 and Y1 for the Foreign Table
  2289.                     ' Find it in the Rel BLOB data.
  2290.                     ' Need to allow logic to determine on which side(left or right)
  2291.                     ' we want the Relationship Line to start from.
  2292.                     ' If the left edge of the Foreign table window is <= to the
  2293.                     ' center of the Primary Table then the Joining line will originate from
  2294.                     ' the left side of the Primary table. Otherwise, it will originate
  2295.                     ' from the right side of the Primary table
  2296.                     If lRet = 0 Then
  2297.                         s = rel.ForeignTable
  2298.                     End If
  2299.  
  2300.                     For i = 0 To rb.NumWindows - 1
  2301.                         If rl(i).WinName = s Then 'rel.ForeignTable Then
  2302.                         'If Trim(rl(i).WinName) = rel.ForeignTable Then
  2303.                             X2 = (rl(i).RelWinX1)
  2304.                             Y2 = (rl(i).RelWinY1)
  2305.                             Y2 = Y2 + (IIf(ReOPf = 0, 1, ReOPf) * 10)
  2306.                             ' Which side of Primary table does the Join line
  2307.                             ' originate from left/right.
  2308.                             ' Handled in StrStorage DLL by DrawLine function
  2309.                             lRet = DrawLine(.RelWinX2 - .RelWinX1, rl(i).RelWinX2 - rl(i).RelWinX1, _
  2310.                             X1, Y1, X2, Y2, lRet)
  2311.                         End If
  2312.                     Next i
  2313.  
  2314.                     Set fld = Nothing
  2315.                     Set tdfForeign = Nothing
  2316.                 End If
  2317.             Next
  2318.  
  2319.         End If
  2320.  
  2321.     End With
  2322.     Set tdf = Nothing
  2323. Next ctr
  2324.  
  2325. HHH:
  2326.  
  2327.  
  2328. ' Output Header before Table Windows
  2329. ' Pass 0 in NumFields param to signal this is Header info.
  2330. ' Pass desired Header info in TableNames param.
  2331. ' Coordinate params will be used to position Header
  2332. ' We have modified the starting Y1 coordinate for all Table Windows
  2333. ' to allow for 1 inch Header section.
  2334.  
  2335.  
  2336. 'SRelTableName = "RelationShip Report:" & Date & Chr(0) 'vbCrLf
  2337. 's = CurrentDb().Name & Chr(0)
  2338. 'lRet = DrawTableWindow(SRelTableName, s, 0, _
  2339. '         10, 10, 400, -1)
  2340.  
  2341.  
  2342. ' Main loop to actually draw each Relationship Table window
  2343. ' and the Tables component fields.
  2344. For ctr = 0 To rb.NumWindows - 1
  2345.     With rl(ctr)
  2346.         On Error Resume Next
  2347.         SRelTableName = .WinName '(.WinName) 'StrConv(.WinName, vbFromUnicode)
  2348.         s = Right$(SRelTableName, 3)
  2349.         lRet = InStr(s, "_")
  2350.         If lRet = 1 Or lRet = 2 Then SRelTableName = Mid$(SRelTableName, 1, Len(SRelTableName) - (4 - lRet))
  2351.         Set tdf = DB.TableDefs(SRelTableName)
  2352.         If Not tdf Is Nothing Then
  2353.             'Get Field Name + Documenting info
  2354.             ' May 16/2008
  2355.             ' Add logic to calc sFields width and use this calculated value
  2356.             ' to determine actual table max width. Remember to take the Table name
  2357.             ' into consideration in calculating max width
  2358.             sFields = DescribeFields(tdf)
  2359.             'lngKt = lngKt + 1&  'Count the tables processed successfully.
  2360.         End If
  2361.  
  2362.        ' lRet = DrawTableWindow(SRelTableName,  sFields, rb.NumWindows, _
  2363.         ' (.RelWinX1 / Xdpi) * 72, (.RelWinY1 / Ydpi) * 72, (((.RelWinX2 - .RelWinX1) / Xdpi) * 72) + 12, ((.RelWinY2 - .RelWinY1) / Ydpi) * 72)
  2364.     lRet = DrawTableWindow(.WinName, sFields, rb.NumWindows, _
  2365.          .RelWinX1, .RelWinY1, (.RelWinX2 - .RelWinX1), (.RelWinY2 - .RelWinY1))
  2366.     End With
  2367.     Set tdf = Nothing
  2368. Next ctr
  2369.  
  2370.  
  2371. ' Do we open new PDF in registered PDF viewer on this system?
  2372. 'If StartPDFViewer = True Then
  2373.  ShellExecuteA Application.hWndAccessApp, "open", sPDF, vbNullString, vbNullString, 1
  2374. 'End If
  2375.  
  2376. On Error GoTo 0
  2377.  
  2378. lRet = EndPDF
  2379.  
  2380. RelationsToPDF = True
  2381.  
  2382. EXIT_RelationsToPDF:
  2383.  
  2384. Set DB = Nothing
  2385. Set tdf = Nothing
  2386. Set fld = Nothing
  2387. Set rel = Nothing
  2388.  
  2389. ' If we aready loaded then free the library
  2390. If hLibStrStorage <> 0 Then
  2391.     hLibStrStorage = FreeLibrary(hLibStrStorage)
  2392. End If
  2393.  
  2394. If hLibDynaPDF <> 0 Then
  2395.     hLibDynaPDF = FreeLibrary(hLibDynaPDF)
  2396. End If
  2397.  
  2398.  
  2399. ' Cleanup
  2400.    lRet = apiSelectObject(hDC, oldfont)
  2401.    ' Delete the Font we created
  2402.    apiDeleteObject (newfont)
  2403.  
  2404.     ' Release the handle to the Screen's DC
  2405.     lRet = apiReleaseDC(0&, hDC)
  2406.  
  2407. Exit Function
  2408.  
  2409. ERR_RelationsToPDF:
  2410. MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
  2411.  
  2412. RelationsToPDF = False
  2413. Resume EXIT_RelationsToPDF
  2414.  
  2415. End Function
  2416.  
Sep 15 '10 #5
NeoPa
32,173 Expert Mod 16PB
Good. I'll look at this when I next get a chance. I was out all evening. It may be the comments I most need, but I'll only know that when I've had a chance to look through it. I'll update you then.
Sep 16 '10 #6
Great, thank you! Just in case here are the explanations:
Expand|Select|Wrap|Line Numbers
  1. 'How it Works:
  2. ' A SnapShot file is created in the normal manner by code like:
  3. '       'Export the selected Report to SnapShot format
  4. '       DoCmd.OutputTo acOutputReport, rptName, "SnapshotFormat(*.snp)", _
  5. '       strPathandFileName
  6. '
  7. ' rptName is the desired Report we are working with.
  8. ' strPathandFileName can be anything, in this Class it is a
  9. ' Temporary FileName and Path created with calls to the
  10. ' GetTempPath and GetUniqueFileName API's.
  11. '
  12. ' We then pass the FileName to the SetupDecompressOrCopyFile API.
  13. ' This will decompress the original SnapShot file into a
  14. ' Temporary file with the same name but a "tmp" extension.
  15. '
  16. ' The decompressed Temp SnapShot file is then passed to the
  17. ' ConvertUncompressedSnapshotToPDF function exposed by StrStorage.DLL.
  18. ' The declaration for this call is at the top of this module.
  19. ' The function uses the Structured Storage API's to
  20. ' open and read the uncompressed Snapshot file. Within this file,
  21. ' there is one Enhanced Metafile for each page of the original report.
  22. ' Additionally, there is a Header section that contains, among other things,
  23. ' a copy of the Report's Printer Devmode structure. We need this to
  24. ' determine the page size of the report.
  25.  
  26. 'The StrStorage DLL exposes the function:
  27. 'Public Function ConvertUncompressedSnapshotToPDF( _
  28. 'UnCompressedSnapShotName As String, _
  29. 'OutputPDFname As String = "", _
  30. 'Optional CompressionLevel As Long = 0, _
  31. 'Optional PasswordOpenAs String = "" _
  32. 'Optional PasswordOwner As String = "" _
  33. 'Optional PasswordRestrictions as Long = 0, _
  34. 'Optional ByVal PDFNoFontEmbedding As Long = 0, _
  35. 'Optional ByVal PDFUnicodeFlags As Long = 0 _
  36. ') As Boolean
  37.  
  38. ' Now we call the ConvertUncompressedSnapshotToPDF funtion exposed by the StrStorage DLL.
  39. '
  40. 'blRet = ConvertUncompressedSnapshot(sFileName as String, sPDFFileName as String)
  41. ' Please note that sFileName must include a full valid path(folder) or it will default
  42. ' to your My Documents folder. For example  "C:\MyPDFs\MonthlyReport.PDF"
  43.  
  44. ' All other parameters are optional.
  45. 'Have Fun!
  46.  
  47. ' Version 7.85
  48. ' Please note that the function signatures for both ConvertUncompressedSnapshotToPDF and ConvertReportToPDF
  49. ' have changed. An optional parameter has been added to expose the conversion of the
  50. ' Metafile to PDF. Flags now include broader support for Unicode and BiDi languages. Finer control
  51. ' over how the Metafile is interpreted is exposed as well.
  52.  
  53. ' Added Security/Encryption
  54. ' Added/Exposed Flags for Unicode
  55. ' Fixed Bug in 11 x 17 paper size
  56. ' Fixed Landscape/Portrait bug
  57.  
  58. ' Version 7.75
  59. ' Added Merge function to merge 2 PDF documents
If i find a solution i'll immediately let you know
Sep 16 '10 #7
TheSmileyCoder
2,321 Expert Mod 2GB
Within the code posted there is a function called GetUniqueFileName:
Expand|Select|Wrap|Line Numbers
  1. Private Function GetUniqueFilename(Optional path As String = "", _
  2. Optional Prefix As String = "", _
  3. Optional UseExtension As String = "") _
  4. As String
  5.  
  6. ' originally Posted by Terry Kreft
  7. ' to: comp.Databases.ms -Access
  8. ' Subject:  Re: Creating Unique filename ??? (Dev code)
  9. ' Date: 01/15/2000
  10. ' Author: Terry Kreft <terry.kreft@mps.co.uk>
  11.  
  12. ' SL Note: Input strings must be NULL terminated.
  13. ' Here it is done by the calling function.
  14.  
  15.   Dim wUnique As Long
  16.   Dim lpTempFileName As String
  17.   Dim lngRet As Long
  18.  
  19.   wUnique = 0
  20.   If path = "" Then path = CurDir
  21.   lpTempFileName = String(MaxPath, 0)
  22.   lngRet = GetTempFileName(path, Prefix, _
  23.                             wUnique, lpTempFileName)
  24.  
  25.   lpTempFileName = Left(lpTempFileName, _
  26.                         InStr(lpTempFileName, Chr(0)) - 1)
  27.   Call Kill(lpTempFileName)
  28.   If Len(UseExtension) > 0 Then
  29.     lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
  30.   End If
  31.   GetUniqueFilename = lpTempFileName
  32. End Function
Within this code the line:
Expand|Select|Wrap|Line Numbers
  1. If path = "" Then path = CurDir
Is where the path gets set to your documents directory, if the function itself has not been passed a parameter. I guess here you could write:
Expand|Select|Wrap|Line Numbers
  1. If path = "" Then path ="C:\WhatEver\IWantToPlace\
Sep 16 '10 #8
NeoPa
32,173 Expert Mod 16PB
That's a (sort of) good answer Smiley. Unfortunately there is an extra level of default here. That procedure (Line #733) defaults to the current folder if no parameter is passed (which it always is in this code). This default is never triggered.

Before the two calls to this procedure in the code (Lines #544 & #561) however, there are lines which set strPath and sPath to the Temp Path (MyDocuments) by calling GetTempPath(). If these two lines are replaced by code setting the values of strPath and sPath to your chosen value instead (personally I'd set up a constant to hold your chosen value for use elsewhere in the code), then you should have exactly what you need.

I wouldn't advise changing the contents of GetTempPath() as you are not planning to use your temp folder. Unless you are of course, then your solution is even easier - You just set that to what you require.

Anyway, Smiley's suggestion, though not 100%, was very helpful in helping me pin down the issue more precisely, so was helpful anyway.

Let us know how you get on with this.
Sep 16 '10 #9
TheSmileyCoder
2,321 Expert Mod 2GB
Guess I jumped the gun there. Good thing you were there to save me!
Sep 16 '10 #10
NeoPa
32,173 Expert Mod 16PB
I could say "It's a good thing you were there to start me off." In fact I think I will. It's ...

Anyway, your post was pretty helpful as it happens, so no problems at all.
Sep 16 '10 #11
First of all, thank you.
Second of all, i already have a constant to hold the file path. Now if by "If these two lines are replaced by code setting the values of strPath and sPath to your chosen value instead" you meant for me to just replace these both variables (strPath & sPath) to my variable, the same for both of them, then i did it - i just set them to DLookup("pdfFilesPath", "tblGlobParams") (that's my path), but i fall in line 759 (Call Kill(lpTempFileName) - error Can't find file.
What am i doing wrong?
Sep 16 '10 #12
NeoPa
32,173 Expert Mod 16PB
This will be much easier and less prone to misunderstanding if you post the relevant bits of the code that you have now and tell us the error message as well as the new line number TC. Describing a change is never the same as showing exactly what is there now, and is particularly fraught when dealing with such vast amounts of code.
Sep 16 '10 #13
I'll try to be more accurate. Here's the relevant code segment, with the bold lines identifying what i changed (lines 41 and 58):
Expand|Select|Wrap|Line Numbers
  1. On Error GoTo ERR_CREATSNAP
  2. Dim strPath  As String
  3. Dim strPathandFileName  As String
  4. Dim strEMFUncompressed As String
  5.  
  6. Dim sOutFile As String
  7. Dim lngRet As Long
  8.  
  9. ' Init our string buffer
  10. strPath = Space(Pathlen)
  11.  
  12. 'Save the ReportName to a local var
  13. mReportName = RptName
  14.  
  15. ' Let's kill any existing Temp SnapShot file
  16. If Len(mUncompressedSnapFile & vbNullString) > 0 Then
  17.     Kill mUncompressedSnapFile
  18.     mUncompressedSnapFile = ""
  19. End If
  20.  
  21. ' If we have been passed the name of a Snapshot file then
  22. ' skip the Snapshot creation process below
  23. If Len(SnapshotName & vbNullString) = 0 Then
  24.  
  25.     ' Make sure we were passed a ReportName
  26.     If Len(RptName & vbNullString) = 0 Then
  27.         ' No valid parameters - FAIL AND EXIT!!
  28.         ConvertReportToPDF = ""
  29.         Exit Function
  30.     End If
  31.  
  32.     ' Get the Systems Temp path
  33.     ' Returns Length of path(num characters in path)
  34.     lngRet = GetTempPath(Pathlen, strPath)
  35.     ' Chop off NULLS and trailing "\"
  36.     strPath = Left(strPath, lngRet) & Chr(0)
  37.  
  38.     ' Now need a unique Filename
  39.     ' locked from a previous aborted attemp.
  40.     ' Needs more work!
  41.     strPath = DLookup("pdfFilesPath", "tblGlobParams")
  42.     strPathandFileName = GetUniqueFilename(strPath, "SNP" & Chr(0), "snp")
  43.  
  44.     ' Export the selected Report to SnapShot format
  45.     DoCmd.OutputTo acOutputReport, RptName, "SnapshotFormat(*.snp)", _
  46.        strPathandFileName
  47.     ' Make sure the process has time to complete
  48.     DoEvents
  49. Else
  50.     strPathandFileName = SnapshotName
  51. End If
  52.  
  53. ' Let's decompress into same filename but change type to ".tmp"
  54. 'strEMFUncompressed = Mid(strPathandFileName, 1, Len(strPathandFileName) - 3)
  55. 'strEMFUncompressed = strEMFUncompressed & "tmp"
  56. Dim sPath As String * 512
  57. lngRet = GetTempPath(512, sPath)
  58. sPath = DLookup("pdfFilesPath", "tblGlobParams")
  59. strEMFUncompressed = GetUniqueFilename(sPath, "SNP", "tmp")
The last line (59) calls for function GetUniqueFilename:
Expand|Select|Wrap|Line Numbers
  1. Private Function GetUniqueFilename(Optional path As String = "", _
  2. Optional Prefix As String = "", _
  3. Optional UseExtension As String = "") _
  4. As String
  5.  
  6. ' originally Posted by Terry Kreft
  7. ' to: comp.Databases.ms -Access
  8. ' Subject:  Re: Creating Unique filename ??? (Dev code)
  9. ' Date: 01/15/2000
  10. ' Author: Terry Kreft <terry.kreft@mps.co.uk>
  11.  
  12. ' SL Note: Input strings must be NULL terminated.
  13. ' Here it is done by the calling function.
  14.  
  15.   Dim wUnique As Long
  16.   Dim lpTempFileName As String
  17.   Dim lngRet As Long
  18.  
  19.   wUnique = 0
  20.   If path = "" Then path = CurDir
  21.   lpTempFileName = String(MaxPath, 0)
  22.   lngRet = GetTempFileName(path, Prefix, _
  23.                             wUnique, lpTempFileName)
  24.  
  25.   lpTempFileName = Left(lpTempFileName, _
  26.                         InStr(lpTempFileName, Chr(0)) - 1)
  27.   Call Kill(lpTempFileName)
  28.   If Len(UseExtension) > 0 Then
  29.     lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
  30.   End If
  31.   GetUniqueFilename = lpTempFileName
  32. End Function
The bold line inside it (27) is where i fall, cause lpTempFileName is empty, and that is when i get the error message "File not found".
Sep 16 '10 #14
NeoPa
32,173 Expert Mod 16PB
You misunderstand me TC. I wasn't being critical (not trying to anyway). Your response was fine, I just felt doing it this would would be easier and more reliable.

I'll look at this now and see what I notice.
Sep 16 '10 #15
No problem, whatever i can do to help myself and you solve this
Sep 16 '10 #16
NeoPa
32,173 Expert Mod 16PB
Ah, this is not a problem and can be handled. I say it's not a problem because it seems clear that the intention is actually to delete the file if it already exists. In other words to ensure the file doesn't exist prior to your creating it.

To handle this, simply add error handling code around your current line #27 of the function :

Expand|Select|Wrap|Line Numbers
  1.   On Error Resume Next
  2.   Call Kill(lpTempFileName)
  3.   On Error GoTo 0
Let us know how you get on.
Sep 16 '10 #17
I added your code. The same line
Expand|Select|Wrap|Line Numbers
  1. strEMFUncompressed = GetUniqueFilename(sPath, "SNP", "tmp")
calls the GetUniqueFilename function, but now there's an error in lines 760-762 of my post number 5 (i don't want to post it again due to its length) -
Expand|Select|Wrap|Line Numbers
  1.   If Len(UseExtension) > 0 Then
  2.     lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
  3.   End If
The error i'm getting is "Invalid procedure call or argument". When i stand on it, lpTempFileName = "", so it basically is Left(-3)..
Sep 16 '10 #18
NeoPa
32,173 Expert Mod 16PB
I still don't need all the code again. Just the stuff relevant to where you're having problems.

The original code doesn't have any of the changes in so, quite apart from there being so much irrelevant code to work through for no benefit, it also doesn't have any of the changes that have already been applied. In effect I'm trying to work with very large amounts of code while having to bear in memory the changes that have already been made. It would make it a lot more practical if you posted the relevant code you're actually struggling with.
Sep 17 '10 #19
I genuinely don't know what else can i do to make myself more clear. As i mentioned, i'm still getting stuck in the same function (GetUniqueFilename), just in a different place this time. I pasted the relevant lines that i get stuck in, here they are again
Expand|Select|Wrap|Line Numbers
  1. If Len(UseExtension) > 0 Then
  2. lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
  3. End If
I copied the error message i'm getting when i reach line 2 (bold) - "Invalid procedure call or argument".
If i can bring more details to the table please let me know.
Sep 17 '10 #20
NeoPa
32,173 Expert Mod 16PB
You said in post #18 that lpTempFileName was found to be empty. I need to see the (current) code that runs before this, that sets lpTempFileName. It's where I expect to find the problem.
Sep 17 '10 #21
After debugging:
First time lpTempFileName fills after function GetUniqueFileName is called for the first time, right before the OutputTo action (strPathandFileName = GetUniqueFilename(strPath, "SNP" & Chr(0), "snp")). That time lpTempFileName has a valid path with snp extension.
The second time is after GetUniqueFilename is called for the second time (strEMFUncompressed = GetUniqueFilename(sPath, "SNP", "tmp")). The sPath = the path i defined. So with this sPath the code goes to GetUniqueFileName:
Expand|Select|Wrap|Line Numbers
  1. Private Function GetUniqueFilename(Optional path As String = "", _
  2. Optional Prefix As String = "", _
  3. Optional UseExtension As String = "") As String
  4.   Dim wUnique As Long
  5.   Dim lpTempFileName As String
  6.   Dim lngRet As Long
  7.  
  8.   wUnique = 0
  9.   If path = "" Then path = CurDir
  10.   lpTempFileName = String(MaxPath, 0)
  11.   lngRet = GetTempFileName(path, Prefix, wUnique, lpTempFileName)
  12.   lpTempFileName = Left(lpTempFileName, InStr(lpTempFileName, Chr(0)) - 1)  On Error Resume Next
  13.   Call Kill(lpTempFileName)
  14.   On Error GoTo 0
  15.  
  16.   If Len(UseExtension) > 0 Then
  17.     lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
  18.   End If
  19.   GetUniqueFilename = lpTempFileName
  20. End Function
In line 10 lpTempFileName gets initialized with some unclear signs (in the immediate window it's just empty).
In line 12 lpTempFileName = "".
In line 18 lpTempFileName is of course still empty, and after this line an error occurs.
Sep 19 '10 #22
NeoPa
32,173 Expert Mod 16PB
Line #12 is required before lpTempFilename can be viewed properly. Unfortunately, you have added the On Error Resume Next to the end of this line. I cannot see how this code could possibly compile or run, so I'm confused and am worrying that what you post may not be accurate. See below (indented) for instructions on what to do before posting code. Always.
When posting any code on here please :
  1. For VBA code specifically :
    1. Ensure you have Option Explicit set (See Require Variable Declaration).
    2. Try to compile it. If it doesn't compile for any reason please explain that clearly - including the error message and which line of your code it appears on. Compilation is done from the Visual Basic Editor menu - Debug \ Compile Project (Where Project is the actual name of your project).
  2. For SQL as well as VBA :
    1. Copy your code (using the Clipboard - Cut / Copy / Paste) from your project directly into your post. Typing in code is not appreciated as it is likely to introduce typos which cause members to waste their time unnecessarily.
    2. Ensure that the code in your post is enveloped within CODE tags. The hash (#) button in the posting page helps with this. Simply select your code and click on the hash button to have it enveloped automatically.
If all these points are covered then all members will be better able to understand, and therefore attempt to answer, your question.
Try splitting line #12 properly and test with it as :
Expand|Select|Wrap|Line Numbers
  1. lpTempFileName = Left(lpTempFileName, InStr(lpTempFileName, Chr(0)) - 1)
  2. On Error Resume Next
The value will not be properly accessible to VBA until line #12 has run properly. It could have all sorts of unpredictable stuff in there.
Sep 20 '10 #23
As to your instructions, this module has option explicit set and my project compiles.
"On error resume next" slided into line 12 by accident while copy-pasting, my bad - i didn't notice. Of course it starts from a new line.
And as i mentioned earlier, lpTempFileName in line 12 = "".
Sep 20 '10 #24
NeoPa
32,173 Expert Mod 16PB
I daren't think what may have caused a copy/paste of code not to work. I hope it doesn't mean I am not seeing what you're actually testing, as that would be worrying.

However, I think I have seen a problem with your line #11. OS functions deal in C type strings, which are always terminated by NullChars. In your code Path and Prefix are not prepared correctly for an OS func. Try instead :
Expand|Select|Wrap|Line Numbers
  1. lngRet = GetTempFileName(path & Chr(0), Prefix & Chr(0), wUnique, lpTempFileName)
Sep 20 '10 #25
What may have caused it is i might have deleted space between lines when writing the post.
I tried your line, it didn't change anything, lngRet = 0 either way.
Sep 20 '10 #26
NeoPa
32,173 Expert Mod 16PB
You may want to try calling GetLastError(). I can't see why it wouldn't work, but then I can't see the parameters you're calling it with either, nor what folders exist and are accessible to your PC. This seems like something you'll need to find by debugging yourself. From your earlier post you seem comfortable with that, but let us know if you need any help with it.

PS. In case you weren't aware, when the call to GetTempFileName returns zero (0) it means it has failed.
Sep 20 '10 #27
Are you sure this function exists in vba? I can't find such.
I'm pretty sure GetTempFileName returns 0 because lpTempFileName is empty,i just have to figure out why it's empty.
Thank you for the effort you've put in trying to solve this.
Sep 20 '10 #28
NeoPa
32,173 Expert Mod 16PB
It's certainly not in the VBA library (I included a link to the description of it in my previous post), but nor is GetTempFileName. Both are windows functions in fact, and need to be declared as such.

The complicated thing about Windows' functions is that they use an interface that is foreign to VBA (and VB incidentally). They expect strings to be NullChar terminated, as is the standard for many programming languages, including C. That is why some fiddling is required whenever calling them from VBA. When sending string data across it must have at least one NullChar (or Chr(0)) appended to the string. When receiving data back, it is important that the correct length of the data be set immediately upon return otherwise the string is in an incomplete state.

I'll try to give an illustration of how the string "Where" would be stored in both cases :
Expand|Select|Wrap|Line Numbers
  1. VBA
  2.   0  1  2  3  4  5  6
  3. |05|00|57|68|65|72|65|
  4. |    5| W| h| e| r| e|
  5. C or Windows
  6.   0  1  2  3  4  5
  7. |57|68|65|72|65|00|
  8. | W| h| e| r| e|NullChar|
In the VBA version 05 00 represents the 16-bit number 5 which is the length of the data. In the Windows version the data starts immediately and continues until a 00 is hit, which in C, starting from 0, would be position #5.
Sep 20 '10 #29

Post your reply

Sign in to post your reply or Sign up for a free account.

Similar topics

11 posts views Thread by Patrick | last post: by
reply views Thread by zhoujie | last post: by
reply views Thread by suresh191 | last post: by
reply views Thread by harlem98 | last post: by
1 post views Thread by Geralt96 | last post: by
reply views Thread by harlem98 | last post: by
By using this site, you agree to our Privacy Policy and Terms of Use.